home *** CD-ROM | disk | FTP | other *** search
/ BBS Toolkit / BBS Toolkit.iso / rbbs_pc / rbbsbas.zip / RBBSSUB4.BAS < prev    next >
BASIC Source File  |  1988-10-02  |  119KB  |  3,083 lines
  1. ' $linesize:132
  2. ' $title: 'RBBSSUB4.BAS CPC17-1A, Copyright 1986 - 88 by D. Thomas Mack'
  3. '  Copyright 1988 by D. Thomas Mack, all rights reserved.
  4. '  Name ...............: RBBSSUB4.BAS
  5. '  Written by .........: D. Thomas Mack
  6. '  First Released .....: September 18, 1988
  7. '  Subsequent Releases.:
  8. '  Copyright ..........: 1986, 1987, 1988
  9. '  Purpose.............: The Remote Bulletin Board System for the IBM PC,
  10. '                        RBBS-PC.BAS utilizes a lot of common subroutines.
  11. '                        Those that do not require error trapping are
  12. '                        incorporated within RBBSSUB2.BAS, RBBSSUB3.BAS,
  13. '                        RBBSSUB4.BAS and RBBSSUB5.BAS as separately
  14. '                        callable subroutines in order to free up as much
  15. '                        code as possible within the 64K code segment
  16. '                        used by RBBS-PC.BAS.
  17. '  Parameters..........: Most parameters are passed via a COMMON statement.
  18. '
  19. ' Subroutine  Line               Function of Subroutine
  20. '   Name     Number
  21. '  ANYBUT     59760   Determine where a "word" begins
  22. '  ASKUSERS   64005   Ask users questions based on a script and save answers
  23. '  ASKMORE    59854   Check whether screen full
  24. '  AUTOPAGE           Check whether to notify sysop caller is on
  25. ' BADFILECHAR 59800   Check file name for bad character
  26. '  BRACKET    59950   Puts strings around a substring
  27. '  BUFFILE    58400   Write a file to the user quickly
  28. '  BUFSTRNG   58300   Write a string with imbedded CR/LF to the user quickly
  29. '  CHKCOLOR   59900+  Highlighting based on search string
  30. '  CHKNARY    58190   Check for the occurance of a string in an array
  31. '  COLORDIR   59920   Adds colorization to FMS directory entry
  32. '  COLORPMT   59924+  Colorizes prompts
  33. '  COMPDATE   59200+  Produces a computational data from YY, MM, DD
  34. '  CONFMAIL   59854   Check conference mail waiting
  35. '  CONVDIRS   58950   Checks for U & A (shorthand) and converts appropriately
  36. '  CSTRDATE   59200   Compress date in string format to 2 characters
  37. '  EOFCOMM    60000   Determine whether any chars in comm port buffer
  38. '  EXPDATE    59854+  Calculate registration expiration date
  39. '  FAKEXRPT   62650   Write out file transfer report for protocols that don't
  40. '  FINDEND    58770   Find where a "word" ends
  41. '  FINDFILE   58790   Determine whether a file exists without opening it
  42. '  FMS        58200   Search the upload management system for entries
  43. '  GETALL     59780   Get list of all directories to display
  44. '  GETDIRS    58900   Prompts for directories for file list/new/search cmds
  45. '  GETMATTR   62530   Restore attributes of original message
  46. '  GETYMD     59200   Pulls YY, MM, or DD from a 2 byte stored date
  47. '  GSANDR     60100   Global search and replace
  48. '  LOGDOWN    59400   Records download in private directory
  49. '  MARKTIME   60200   Give visual feedback during lengthy process
  50. '  METAGSR    60102+  Meta statement global search and replace
  51. '  MIMPORT    59700   Allow local user to import a text file to a message
  52. '  MUZAK      59100   Play musical themes for different RBBS functions
  53. '  PERSFILE   59300   View and select personal files for downloading
  54. '  PROTOCOL   62600   Determine if external protocols are available
  55. '  PUTMATTR   62520   Save attributes of original message
  56. '  REMOVE     58210   Remove characters from within strings
  57. '  ROTORSDIR  58700   Searches for a file using list of subdirs
  58. '  RPTTIME    62530+  Report date/time and time on
  59. '  SETABORT   58750   Set time for a process to abort
  60. '  SETECHO    59600   Set RBBS properly for who is to echo
  61. '  SETHILITE  59900+  Set user preference on highlighting
  62. '  SMARTTXT   58250   Process SMART TEXT control strings
  63. '  SUBMENU    59500   Processes options that have sub-menus
  64. '  TIMEDOUT   63000   Write timed exit semaphore file
  65. '  TIMELOCK   60150   Check for TIME LOCK on certain features
  66. '  TRANSFER   62620   RBBS-PC support for external protocols for file transfer
  67. '  TOGGLE     57000   Toggles or views user options
  68. ' TWOBYTEDATE 59200   Reduces a data to 2 byte string for space compression
  69. '  USERCOLOR  59970   Lets user set color for text and whether bold
  70. '  USERFACE   59450   Processes programmable user interface
  71. '  VIEWARC    64600   Display .ARC file contents to user
  72. '  XFRETURN   62629   Private door exit routine
  73. '  WIPELINE   58800   Wipes away a line so next prints in its place
  74. '  WORDWRAP   59700+  Adjust a message --wrap linesand perserve paragraphs
  75. '
  76. '  $INCLUDE: 'RBBS-VAR.BAS'
  77. '
  78. ' $SUBTITLE: 'TOGGLE - Toggle User Preferences'
  79. ' $PAGE
  80. '
  81. '  SUBROUTINE NAME    -- TOGGLE
  82. '
  83. '  INPUT PARAMETERS   -- TOGGLE.OPTION      Option to toggle or view
  84. '                                           according to the following:
  85. '    TOGGLE.OPTION         PREFERENCE
  86. '   TOGGLE   VIEW
  87. '     1       -1           Autodownload
  88. '     2       -2           Bulletin review on logon
  89. '     3       -3           Case change
  90. '     4       -4           File review on logon
  91. '     5       -5           Highlight
  92. '     6       -6           Line feeds
  93. '     7       -7           Nulls
  94. '     8       -8           TurboKey
  95. '     9       -9           Expert
  96. '    10      -10           Bell
  97. '
  98. '  OUTPUT PARAMETERS  -- SUBROUTINE.PARAMETER   passed from TPUT
  99. '
  100. '  SUBROUTINE PURPOSE -- Sets or views any single user preference value
  101. '
  102.       SUB TOGGLE (TOGGLE.OPTION) STATIC
  103. 57000 SUBROUTINE.PARAMETER = 0
  104.       IF TOGGLE.OPTION < 0 THEN _
  105.          GOTO 57005
  106.       ON TOGGLE.OPTION GOSUB _
  107.          57010, _         'Autodownload
  108.          57120, _         'Bulletin review on logon
  109.          57260, _         'Case change
  110.          57150, _         'File review on logon
  111.          57040, _         'Highlight
  112.          57100, _         'Line feeds
  113.          57210, _         'Nulls
  114.          57230, _         'TurboKey
  115.          57190, _         'Expert
  116.          57170            'Bell
  117.       EXIT SUB
  118. 57005 CALL ASKMORE ("",TRUE,TRUE,X,TRUE)
  119.       ON -TOGGLE.OPTION GOSUB _
  120.          57030, _         'Autodownload
  121.          57130, _         'Bulletin review on logon
  122.          57270, _         'Case change
  123.          57160, _         'File review on logon
  124.          57050, _         'Highlight
  125.          57110, _         'Line feeds
  126.          57220, _         'Nulls
  127.          57240, _         'TurboKey
  128.          57200, _         'Expert
  129.          57180            'Bell
  130.       EXIT SUB
  131. 57010 IF AUTODOWNLOAD.DESIRED THEN _
  132.          GOTO 57020
  133.       IF NOT AUTODOWNLOAD.VERIFIED THEN _
  134.          CALL TESTUSER
  135.       IF NOT AUTODOWNLOAD.AVAILABLE THEN _
  136.          CALL QTPUT ("Your comm pgm does not support AUTODOWNLOAD",1) : _
  137.          AUTODOWNLOAD.DESIRED = TRUE
  138. 57020 AUTODOWNLOAD.DESIRED = NOT AUTODOWNLOAD.DESIRED
  139. 57030 A$ = "Autodownload " + FNOFFON$(AUTODOWNLOAD.DESIRED)
  140.      CALL QTPUT (A$,1)
  141.      RETURN
  142. 57040 IF EMPHASIZE.ON.DEF$ = "" THEN _
  143.         CALL QTPUT ("Highlighting unavailable",1) : _
  144.         RETURN
  145.      CALL SETHILITE (NOT HIGHLIGHT.OFF)
  146.      IF HIGHLIGHT.OFF THEN _
  147.         CALL QTPUT (COLOR.RESET$,0)
  148.      GOSUB 57050
  149.      CALL USERCOLOR
  150.      RETURN
  151. 57050 IF EMPHASIZE.ON$ <> "" THEN _
  152.         EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + _
  153.         ";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m"
  154.      CALL QTPUT (EMPHASIZE.ON$ + "Highlighting" + EMPHASIZE.OFF$ + _
  155.                  " " + FNOFFON$(NOT HIGHLIGHT.OFF),1)
  156.      RETURN
  157. 57100 LINE.FEEDS = NOT LINE.FEEDS
  158.       IF LOCAL.USER THEN _
  159.          LINE.FEEDS = TRUE
  160. 57110 CALL QTPUT("Line Feeds " + FNOFFON$(LINE.FEEDS),1)
  161.       CALL SETCRLF
  162.       RETURN
  163. 57120 CHECK.BULLETIN.LOGON = NOT CHECK.BULLETIN.LOGON
  164. 57130 A$ = MID$("SKIP CHECK",1 -5 * CHECK.BULLETIN.LOGON,5) + _
  165.            " old BULLETINS in logon"
  166.       CALL QTPUT (A$,1)
  167.       RETURN
  168. 57150 SKIP.FILES.LOGON = NOT SKIP.FILES.LOGON
  169. 57160 A$ = MID$("CHECKSKIP",1 -5 * SKIP.FILES.LOGON,5) + _
  170.            " new files in logon"
  171.       CALL QTPUT (A$,1)
  172.       RETURN
  173. 57170 PROMPT.BELL = NOT PROMPT.BELL
  174. 57180 A$ = "Prompt Bell " + FNOFFON$(PROMPT.BELL)
  175.       CALL QTPUT (A$,1)
  176.       RETURN
  177. 57190 EXPERT.USER = NOT EXPERT.USER
  178.       CALL SETEXPERT
  179. 57200 A$ = MID$("NoviceExpert",1 -6 * EXPERT.USER,6)
  180.       CALL QTPUT (A$,1)
  181.       RETURN
  182. 57210 NULLS = NOT NULLS
  183.       NUL$ = MID$(STRING$(5,0),1, - 5 * NULLS)
  184.       CALL SETCRLF
  185. 57220 A$ = "Nulls " + FNOFFON$(NULLS)
  186.       CALL QTPUT (A$,1)
  187.       RETURN
  188. 57230 TURBO.KEY.USER = NOT TURBO.KEY.USER
  189. 57240 CALL QTPUT ("TurboKey " + FNOFFON$(TURBO.KEY.USER),1)
  190.       RETURN
  191. 57260 UPPER.CASE = NOT UPPER.CASE
  192. 57270 A$ = "UPPER CASE " + _
  193.             MID$("and lowerONLY",1 - 9 * UPPER.CASE,9)
  194.       CALL QTPUT (A$,1)
  195. 57280 USE.TPUT = (UPPER.CASE OR XON.XOFF)
  196.       RETURN
  197.       END SUB
  198. '
  199. ' $SUBTITLE: 'CHKNARY - subroutine to check for a string in an array'
  200. ' $PAGE
  201. '
  202. '  SUBROUTINE NAME    -- CHKNARY
  203. '
  204. '  INPUT PARAMETERS   -- PARAMETER                      MEANING
  205. '                        ELEMENT$                THE STRING TO CHECK FOR
  206. '                        ARRAY$()                THE ARRAY TO BE SEARCHED
  207. '                        NUM.ENTRIES.TO.SEARCH   NUMBER OF ENTRIES WITHIN IN
  208. '                                                THE ARRAY TO BE SEARCHED
  209. '
  210. '  OUTPUT PARAMETERS  -- IS.IN.ARA               0 = STRING NOT FOUND IN THE
  211. '                                                    ARRAY SPECIFIED
  212. '                                                OTHERWISE IT IS THE NUMBER OF
  213. '                                                ELEMENT WITHIN THE ARRAY THAT
  214. '                                                WAS FOUND TO MATCH
  215. '
  216. '  SUBROUTINE PURPOSE -- SEARCH AN ARRAY FOR A SPECIFIED STRING AND, IF FOUND,
  217. '                        RETURN THE NUMBER OF THE ELEMENT THAT MATCHED.
  218. '
  219.       SUB CHKNARY (ELEMENT$,ARRAY$(1),NUM.ENTRIES.TO.SEARCH,IS.IN.ARA) STATIC
  220. 58190 IS.IN.ARA = 1
  221.       CALL ALLCAPS (ELEMENT$)
  222.       MAX.TRIES = NUM.ENTRIES.TO.SEARCH + 1
  223.       ARRAY$(MAX.TRIES) = ELEMENT$
  224.       WHILE ARRAY$(IS.IN.ARA) <> ELEMENT$
  225.          IS.IN.ARA = IS.IN.ARA + 1
  226.       WEND
  227.       IF IS.IN.ARA = MAX.TRIES THEN _
  228.          IS.IN.ARA = 0
  229.       END SUB
  230. ' $SUBTITLE: 'FMS - subroutine to search the upload management system'
  231. ' $PAGE
  232. '
  233. '  SUBROUTINE NAME    -- FMS
  234. '
  235. '  INPUT PARAMETERS   -- PARAMETER                      MEANING
  236. '                        DIR.TO.SEARCH$          RBBS-PC "DIR" CATEGORY TO LOOK
  237. '                                                FOR
  238. '                        SEARCH.STRING$          STRING TO SEARCH FOR
  239. '                        SEARCH.DATE$            DATE TO SEARCH FOR
  240. '                        CATEGORY.NAME$()
  241. '                        CATEGORY.CODE$()
  242. '                        CATEGORY.DESC$()
  243. '                        CAT.FOUND
  244. '                        NUM.CATEGORIES
  245. '
  246. '  OUTPUT PARAMETERS  -- PROCESSED.IN.FMS
  247. '                        DOWNLOAD.FLAG
  248. '
  249. '  SUBROUTINE PURPOSE -- TO SEARCH THE UPLOAD MANAGMENT SYSTEM AND DISPLAY THE
  250. '                        FILES BEING SEARCHED FOR AS WELL AS THE CATEGORY DE-
  251. '                        SCRIPTIONS
  252. '
  253.       SUB FMS (DIR.TO.SEARCH$,SEARCH.STRING$,SEARCH.DATE$, _
  254.                PROCESSED.IN.FMS,CATEGORY.NAME$(1),CATEGORY.CODE$(1), _
  255.                CATEGORY.DESC$(1),DOWNLOAD.FLAG,CAT.FOUND,ABORT.INDEX) STATIC
  256. 58200 DOWNLOAD.FLAG = 0
  257.       CALL CHKNARY (DIR.TO.SEARCH$,CATEGORY.NAME$(),NUM.CATEGORIES,CAT.FOUND)
  258.       PROCESSED.IN.FMS = PROCESSED.IN.FMS OR (CAT.FOUND > 0)
  259.       IF PROCESSED.IN.FMS THEN _
  260.          SUBROUTINE.PARAMETER = 5 : _
  261.          GOSUB 58202 : _
  262.          A$ = "Scanning directory " + _
  263.               DIR.TO.SEARCH$ + _
  264.               HDR$ + _
  265.               " - " + _
  266.               CATEGORY.DESC$(CAT.FOUND) : _
  267.          CALL TPUT : _
  268.          CAT$ = CATEGORY.CODE$(CAT.FOUND) : _
  269.          CALL DISUPDIR (CAT$,SEARCH.STRING$,SEARCH.DATE$,DOWNLOAD.FLAG,ABORT.INDEX)
  270.       EXIT SUB
  271. 58202 A$ = SEARCH.DATE$
  272.       IF LEN(A$) > 0 THEN _
  273.          A$ = MID$(A$,3) + LEFT$(A$,2)
  274.       HDR$ = " for " + _
  275.              SEARCH.STRING$ + _
  276.              A$
  277.       IF LEN(HDR$) < 6 THEN _
  278.          HDR$ = ""
  279.       RETURN
  280.       END SUB
  281. ' $SUBTITLE: 'REMOVE - subroutine to delete a string from within a string'
  282. ' $PAGE
  283. '
  284. '  SUBROUTINE NAME    -- REMOVE
  285. '
  286. '  INPUT PARAMETERS   -- PARAMETER                      MEANING
  287. '                        BADSTRING$              STRING CONTAINING CHARACTERS
  288. '                                                TO BE DELETED FROM "L$"
  289. '                        L$                      STRING TO BE ALTERED
  290. '
  291. '  OUTPUT PARAMETERS  -- L$                      WITH THE CHARACTERS IN
  292. '                                                "BADSTRING#" DELETED FROM IT
  293. '
  294. '  SUBROUTINE PURPOSE -- TO REMOVE ALL INSTANCES OF THE CHARACTERS IN
  295. '                        "BADSTRING$" FROM "L$"
  296. '
  297.       SUB REMOVE (L$,BADSTRNG$) STATIC
  298. 58210 J = 0
  299.       FOR I=1 TO LEN(L$)
  300.          IF INSTR(BADSTRNG$,MID$(L$,I,1)) = 0 THEN _
  301.             J = J + 1 : _
  302.             MID$(L$,J,1) = MID$(L$,I,1)
  303.       NEXT I
  304.       L$ = LEFT$(L$,J)
  305.       END SUB
  306. '
  307. ' $SUBTITLE: 'SMARTTXT - smart text substitution'
  308. ' $PAGE
  309. '
  310. '  SUBROUTINE NAME    -- SMARTTXT   (WRITTEN BY DOUG AZZARITO)
  311. '
  312. '  INPUT PARAMETERS   -- STRNG.WORK$        string to scan for Smart Text
  313. '                        CR.FOUND           Does this line contain a CR?
  314. '                        SMART.TEXT         Smart Text control code
  315. '
  316. '  OUTPUT PARAMETERS  -- STRNG.WORK$        Input string with Smart replaced
  317. '
  318. '  SUBROUTINE PURPOSE -- Smart Text allows control strings in text files
  319. '                        to be replaced at runtime with user info or other
  320. '                        data.  The Smart Text control code is a 1-byte
  321. '                        code (configurable) with a 2-byte action code.
  322. '
  323.       SUB SMARTTXT (STRNG.WORK$, CR.FOUND) STATIC
  324. 58250 IF SMART.CARRY$<>"" THEN _
  325.          STRNG.WORK$ = SMART.CARRY$+STRNG.WORK$
  326.       INDEX = INSTR(STRNG.WORK$, SMART.TEXT$)
  327.       WHILE INDEX > 0 AND INDEX < LEN(STRNG.WORK$)-1
  328.          IF INSTR(MID$(STRNG.WORK$, INDEX+1,2)," ") THEN _
  329.             SMART.ACT = 0 _
  330.          ELSE _
  331.             SMART.ACT = INSTR(SMART.TABLE$, MID$(STRNG.WORK$, INDEX+1, 2))
  332.          IF SMART.ACT > 0 THEN _
  333.             SMART.ACT = (SMART.ACT+2)/3 : _
  334.             ON SMART.ACT GOSUB 58260, 58261, 58262, 58263, 58264, 58265, _
  335.                          58266, 58267, 58268, 58269, 58270, _
  336.                          58271, 58272, 58273, 58274, 58275, _
  337.                          58276, 58277, 58278, 58279, 58280, _
  338.                          58281, 58282, 58283, 58284 : _
  339.             STRNG.WORK$ = LEFT$(STRNG.WORK$, INDEX-1) + SMART.HOLD$ + _
  340.                MID$(STRNG.WORK$,INDEX+3)
  341.          INDEX = INSTR(INDEX+1, STRNG.WORK$, CHR$(SMART.TEXT))
  342.       WEND
  343.       IF INDEX AND (INDEX > LEN(STRNG.WORK$)-2) AND NOT CR.FOUND THEN _
  344.          SMART.CARRY$ = MID$(STRNG.WORK$,INDEX) : _
  345.          STRNG.WORK$ = LEFT$(STRNG.WORK$,INDEX-1) : _
  346.       ELSE _
  347.          SMART.CARRY$ = ""
  348.       EXIT SUB
  349. 58260 LINES.PRINTED = 0                     ' CS (Clear screen line count reset)
  350.       SMART.HOLD$ = ""
  351.       RETURN
  352. 58261 LINES.PRINTED = PAGE.LENGTH           ' PB Page Break
  353.       IF NON.STOP THEN _                    ' force a 1-time pause
  354.          ONE.STOP = TRUE : _                ' if NON STOP is on
  355.          NON.STOP = FALSE
  356.       SMART.HOLD$ = ""
  357.       FORCE.KEYBOARD = TRUE
  358.       RETURN
  359. 58262 NON.STOP = TRUE                       ' NS Non-stop
  360.       SMART.HOLD$ = ""
  361.       RETURN
  362. 58263 SMART.HOLD$ = FIRST.NAME$             ' FN User's FIRST name
  363.       RETURN
  364. 58264 SMART.HOLD$ = LAST.NAME$              ' LN User's LAST name
  365.       RETURN
  366. 58265 SMART.HOLD$ = MID$(STR$(USER.SECURITY.LEVEL),2)   ' SL Security level
  367.       RETURN
  368. 58266 SMART.HOLD$ = DATE$
  369.       RETURN
  370. 58267 CALL AMORPM
  371.       SMART.HOLD$ = TIM$
  372.       RETURN
  373. 58268 CALL TIMEREMAIN(TIME.REMAINING!)      ' TR Time remaining (in mins)
  374.       SMART.HOLD$ = MID$(STR$(INT(TIME.REMAINING!)),2)
  375.       RETURN
  376. 58269 CALL TIMEREMAIN(TIME.REMAINING!)      ' TE Time elapsed (mm:ss)
  377.       SMART.HOLD$ = MID$(STR$(INT(TCA!/60)),2)+":"+ MID$(STR$((TCA! MOD 60)+100),3)
  378.       RETURN
  379. 58270 SMART.HOLD$ = MID$(STR$(INT((TIME.LOCK.SET+0.5)/60)),2) ' TL - Time Lock period
  380.       SMART.HOLD$ = SMART.HOLD$ + ":"+ MID$(STR$((TIME.LOCK.SET MOD 60)+100),3)
  381.       RETURN
  382. 58271 SMART.HOLD$ = MID$(STR$(DAYS.IN.REGISTRATION.PERIOD),2)
  383.       RETURN                                ' RP Registration Length
  384. 58272 SMART.HOLD$ = MID$(STR$(REG.DAYS.REMAINING),2)
  385.       RETURN                                ' RR Registration Remaining
  386. 58273 SMART.HOLD$ = CITY.STATE$             ' CT Users CITY & STATE
  387.       RETURN
  388. 58274 SMART.HOLD$ = FG.1$                   ' C1 Color 1
  389.       RETURN
  390. 58275 SMART.HOLD$ = FG.2$                   ' C2 Color 2
  391.       RETURN
  392. 58276 SMART.HOLD$ = FG.3$                   ' C3 Color 3
  393.       RETURN
  394. 58277 SMART.HOLD$ = FG.4$                   ' C4 Color 4
  395.       RETURN
  396. 58278 SMART.HOLD$ = EMPHASIZE.OFF$          ' C0 Reset color
  397.       RETURN
  398. 58279 SMART.HOLD$ = MID$(STR$(INT(DL.TODAY!)),2)
  399.       RETURN                                ' DD files Dnlded TODAY
  400. 58280 SMART.HOLD$ = MID$(STR$(INT(BYTES.TODAY!)),2)
  401.       RETURN                                ' BD Bytes Dnlded TODAY
  402. 58281 SMART.HOLD$ = MID$(STR$(INT(DLBYTES!)),2)
  403.       RETURN                                ' DB Download Bytes
  404. 58282 SMART.HOLD$ = MID$(STR$(INT(ULBYTES!)),2)
  405.       RETURN                                ' UB Upload Bytes
  406. 58283 SMART.HOLD$ = MID$(STR$(DOWNLOADS),2) ' DL Number of Dnlds
  407.       RETURN
  408. 58284 SMART.HOLD$ = MID$(STR$(UPLOADS),2)   ' UL Number of Uplds
  409.       RETURN
  410.       END SUB
  411. '
  412. ' $SUBTITLE: 'BUFSTRNG - subroutine to write a string with imbedded CR/LF'
  413. ' $PAGE
  414. '
  415. '  SUBROUTINE NAME    -- BUFSTRNG
  416. '
  417. '  INPUT PARAMETERS   -- PARAMETER                      MEANING
  418. '                        STRNG$                  STRING TO BE WRITTEN OUT
  419. '                        DATA.SIZE               LENGTH OF STRING - # LEFT
  420. '                                                    CHARS TO OUTPUT
  421. '
  422. '  OUTPUT PARAMETERS  -- STRNG$                  IS WRITTEN TO THE USER
  423. '
  424. '  SUBROUTINE PURPOSE -- TO SEARCH THE STRING, STRNG$, FOR IMBEDDED CARRIAGE
  425. '                        RETURNS AND LINE FEEDS AND WRITE OUT EACH LINE WITH
  426. '                        THE APPROPRIATE SUBSTITUTION (CR/LF IF TO THE LOCAL
  427. '                        SCREEN OR CR/NULLS/LF IF TO THE COMMUNICATIONS PORT).
  428. '
  429. 58300 SUB BUFSTRNG (STRNG$,PASSED.DATA.SIZE,ABORT.INDEX) STATIC
  430.       L = LEN(STRNG$)
  431.       IF PASSED.DATA.SIZE < L THEN _
  432.          L = PASSED.DATA.SIZE
  433.       IF L < 1 THEN _
  434.          EXIT SUB
  435.       FF = PAGE.LENGTH - 1
  436.       START.BYTE = 1
  437.       IF CARRY.OVER THEN _
  438.          IF ASC(STRNG$) = 10 THEN _
  439.             START.BYTE = 2 : _
  440.             CALL SKIPLINE (1)
  441.       CARRY.OVER = (MID$(STRNG$,L,1) = CARRIAGE.RETURN$)
  442.       L = L + CARRY.OVER
  443. 58301 CRAT = INSTR(START.BYTE,STRNG$,CARRIAGE.RETURN$)
  444.       IF CRAT > 0 AND CRAT < L THEN _
  445.          CR.FOUND = (MID$(STRNG$,CRAT + 1,1) = LINE.FEED$) _
  446.       ELSE CR.FOUND = FALSE
  447.       EOL.LEN = -2 * CR.FOUND
  448.       IF CR.FOUND THEN _
  449.          EOD = CRAT _
  450.       ELSE EOD = L + 1
  451.       NUM.BYTES = EOD - START.BYTE
  452.       STRNG.WORK$ = MID$(STRNG$,START.BYTE,NUM.BYTES)
  453.       IF NOT DELETE.INVALID THEN _
  454.          GOTO 58304
  455.       INDEX = INSTR(STRNG.WORK$,"[")
  456.       J = LEN(STRNG.WORK$) - 1
  457.       WHILE INDEX > 0 AND INDEX < J
  458.          IF MID$(STRNG.WORK$,INDEX + 2,1) = "]" THEN _
  459.             IF INSTR (INVALID.OPTS$,MID$(STRNG.WORK$,INDEX + 1,1)) THEN _
  460.                MID$(STRNG.WORK$,INDEX + 1,1) = "*"
  461.          INDEX = INSTR(INDEX + 1,STRNG.WORK$,"[")
  462.       WEND
  463. 58304 IF SMART.TEXT THEN _
  464.          CALL SMARTTXT (STRNG.WORK$, CR.FOUND)
  465.       CALL QTPUT (STRNG.WORK$, - (CR.FOUND))
  466.       IF RET THEN _
  467.          EXIT SUB
  468.       IF LINES.PRINTED < FF THEN _
  469.          GOTO 58305
  470.       CALL CHKTREMAIN (TIME.REMAINING!)
  471.       CALL CARRIER
  472.       IF SUBROUTINE.PARAMETER = -1 THEN _
  473.          EXIT SUB
  474.       IF NON.STOP THEN _
  475.          GOTO 58305
  476.       CALL ASKMORE ("",TRUE,FALSE,ABORT.INDEX,STOP.INTERRUPTS)
  477.       IF NO THEN _
  478.          RET = TRUE : _
  479.          EXIT SUB
  480. 58305 START.BYTE = EOD + EOL.LEN
  481.       IF START.BYTE <= L THEN _
  482.          GOTO 58301
  483.       END SUB
  484. ' $SUBTITLE: 'BUFFILE - subroutine to write a sequential file to the user'
  485. ' $PAGE
  486. '
  487. '  SUBROUTINE NAME    -- BUFFILE
  488. '
  489. '  INPUT PARAMETERS   -- PARAMETER                      MEANING
  490. '                        FILENAME$               NAME OF THE FILE TO WRITE TO
  491. '                                                OUT TO THE USER
  492. '
  493. '  OUTPUT PARAMETERS  -- NONE                    FILE IS WRITTEN TO THE USER
  494. '
  495. '  SUBROUTINE PURPOSE -- TO DISPLAY A SEQUENTIAL FILE TO THE USER
  496. '
  497. 58400 SUB BUFFILE (FILNAME$,ABORT.INDEX) STATIC
  498.       CALL FINDIT (FILNAME$)
  499.       IF NOT OK THEN _
  500.          EXIT SUB
  501.       NO = FALSE
  502.       CALL OPENRSEQ (FILNAME$,NUM.RECS,LEN.LAST.REC,BUFFER.SIZE)
  503.       DATA.SIZE = BUFFER.SIZE
  504.       FIELD 2, DATA.SIZE AS SEQ.REC$
  505.       NON.STOP = NON.STOP OR (PAGE.LENGTH < 1)
  506.       IF NOT STOP.INTERRUPTS THEN _
  507.          IF NOT CONCAT.FILES THEN _
  508.             IF NOT NON.STOP THEN _
  509.                A$ = "* Ctrl-K(^K) / ^X aborts. ^S suspends ^Q resumes *" : _
  510.                SUBROUTINE.PARAMETER = 2 : _
  511.                CALL TPUT
  512.       TU = 0
  513. 58405 TU = TU + 1
  514.       IF TU < NUM.RECS THEN _
  515.          GET 2,TU _
  516.       ELSE IF TU = NUM.RECS THEN _
  517.               GET 2,TU : _
  518.               X = INSTR(SEQ.REC$,CHR$(26)) : _
  519.               IF X = 0 OR X > LEN.LAST.REC THEN _
  520.                  DATA.SIZE = LEN.LAST.REC _
  521.               ELSE DATA.SIZE = X - 1 _
  522.            ELSE GOTO 58419
  523.       IF LOCAL.USER THEN _
  524.          GOTO 58406
  525.       CALL EOFCOMM (CHAR%)
  526.       IF CHAR% <> -1 THEN _
  527.          GOTO 58407            ' comm port input
  528. 58406 KEYBOARD.STACK$ = INKEY$
  529.       IF KEYBOARD.STACK$ = "" THEN _  ' no keyboard input
  530.          CALL BUFSTRNG (SEQ.REC$,DATA.SIZE,ABORT.INDEX) : _
  531.          GOTO 58408
  532. 58407 A$ = LEFT$(SEQ.REC$,DATA.SIZE)  ' process comm/keyboard
  533.       SUBROUTINE.PARAMETER = 4
  534.       CALL TPUT
  535. 58408 IF SUBROUTINE.PARAMETER <> -1 AND NOT RET THEN _
  536.          GOTO 58405
  537. 58419 CLOSE 2
  538.       BYPASS.TIME.CHECK = FALSE
  539.       STOP.INTERRUPTS = FALSE
  540.       CALL QTPUT (EMPHASIZE.OFF$,0)
  541.       END SUB
  542. ' $SUBTITLE: 'FINDLAST - subroutine to find last occurence of a string'
  543. ' $PAGE
  544. '
  545. '  SUBROUTINE NAME    -- FINDLAST
  546. '
  547. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  548. '                        LOOK.IN$           STRING TO LOOK INTO
  549. '                        LOOK.FOR$          STRING TO SEARCH FOR
  550. '
  551. '  OUTPUT PARAMETERS  -- WHERE.FOUND        POSITION IN LOOK.IN$ THAT
  552. '                                            LOOK.FOR$ FOUND
  553. '                        NUM.FINDS          HOW MANY OCCURENCES IN LOOK.IN$
  554. '
  555. '  SUBROUTINE PURPOSE -- FINDS LAST OCCURANCE OF LOOK.FOR$ IN LOOK.IN$ AND
  556. '                        RETURNS COUNT OF # OF OCCURANCES.  IF NONE FOUND,
  557. '                        BOTH RETURNED PARAMETERS ARE SET TO 0.
  558. '
  559.       SUB FINDLAST (LOOK.IN$,LOOK.FOR$,WHERE.FOUND,NUM.FINDS) STATIC
  560. 58600 WHERE.FOUND = INSTR(LOOK.IN$,LOOK.FOR$)
  561.       NUM.FINDS = -(WHERE.FOUND > 0)
  562.       NEXT.FOUND = INSTR(WHERE.FOUND + 1,LOOK.IN$,LOOK.FOR$)
  563.       WHILE NEXT.FOUND > 0
  564.          NUM.FINDS = NUM.FINDS + 1
  565.          WHERE.FOUND = NEXT.FOUND                                    ' FORMAT
  566.          NEXT.FOUND = INSTR(WHERE.FOUND + 1,LOOK.IN$,LOOK.FOR$)
  567.       WEND
  568.       END SUB
  569. ' $SUBTITLE: 'ROTORSDIR - search thru a list of subdirs for a file'
  570. ' $PAGE
  571. '
  572. '  SUBROUTINE NAME    -- ROTORSDIR
  573. '
  574. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  575. '                        FILNAME$                  FILE NAME TO LOOK FOR
  576. '                        SDIR.ARA                  ARRAY OF SUBDIRECTORIES
  577. '                        MAX.SEARCH                MAX # OF SUBDIRECTORIES
  578. '                        MARK.TIME                 WHETHER TO MARK TIME
  579. '
  580. '   OUTPUT PARAMETERS -- FNAME$                    ADD SUBDIRECTORY TO THE
  581. '                                                  FILE NAME IF FOUND.  OTHER-
  582. '                                                  WISE DON'T.
  583. '                        OK                        TRUE IF FILE WAS FOUND
  584. '
  585. '  SUBROUTINE PURPOSE -- HUNT THROUGH A LIST OF SUBDIRECTORIES TO DETERMINE
  586. '                        IF A FILE IS IN ANY OF THEM.  IF FILE IS FOUND, OPEN
  587. '                        THE FILE AS FILE #2, ADD THE DRIVE/PATH TO THE FILE
  588. '                        NAME, AND SETS OK TO TRUE.  IF FILE ISN'T FOUND, SET
  589. '                        FILE NAME TO THE LAST SUBDIRECTORY SEARCHED -- WHICH
  590. '                        SHOULD BE THE UPLOAD SUBDIRECTORY.
  591. '
  592. '                        IF THE LIBRARY MENU IS SELECTED (MENU.INDEX = 6), THEN
  593. '                        ONLY 2 SUBDIRECTORIES ARE SEARCHED. THE FIRST BEING
  594. '                        THE WORK DISK AND THE SECOND BEING THE SELECTED
  595. '                        LIBRARY DISK.
  596. '
  597.       SUB ROTORSDIR (FILNAME$,SDIR.ARA$(1),MAX.SEARCH,MARK.TIME) STATIC
  598. 58700 OK = FALSE
  599.       IF MARK.TIME THEN _
  600.          CALL QTPUT ("Searching for "+FILNAME$,0)
  601.       IF MENU.INDEX = 6 THEN _
  602.          GOTO 58705
  603.       NUM.SEARCH = 1
  604.       X = 0
  605.       WHILE (NOT OK) AND NUM.SEARCH <= MAX.SEARCH AND _
  606.          SDIR.ARA$(NUM.SEARCH) <> ""
  607.          IF MARK.TIME THEN _
  608.             CALL MARKTIME (X)
  609.          X$ = SDIR.ARA$(NUM.SEARCH) + _
  610.               FILNAME$
  611.          CALL FINDIT (X$)
  612.          NUM.SEARCH = NUM.SEARCH + 1
  613.       WEND
  614.       GOTO 58710
  615. 58705 X$ = LIBRARY.WORK.DISK.PATH$ + _
  616.            FILNAME$
  617.       CALL FINDIT (X$)
  618.       IF OK THEN _
  619.          GOTO 58710
  620.       X$ = LIBRARY.DRIVE$ + _
  621.            FILNAME$
  622.       CALL FINDIT (X$)
  623. 58710 FILNAME$ = X$
  624.       CALL SKIPLINE (-MARK.TIME)
  625.       END SUB
  626. ' $SUBTITLE: 'WIPELINE - Wipe away a line so next overprints'
  627. ' $PAGE
  628. '
  629. '  SUBROUTINE NAME    -- WIPELINE
  630. '
  631. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  632. '                            CARRIAGE.RETURN$
  633. '                            CHARS.TO.WIPE            # OF CHARACTERS TO BLANK
  634. '                            NULLS
  635. '
  636. '   OUTPUT PARAMETERS -- NONE
  637. '
  638. '  SUBROUTINE PURPOSE -- WIPE AWAY A LINE AND LEAVE CURSOR AT BEGINNING OF THE
  639. '                        SAME LINE SO THAT THE NEXT LINE WILL PRINT IN ITS
  640. '                        PLACE
  641. '
  642.       SUB WIPELINE (CHARS.TO.WIPE) STATIC
  643. 58800 IF NULLS OR CHARS.TO.WIPE > 79 THEN _
  644.          CALL SKIPLINE (1) : _
  645.          EXIT SUB
  646.       IF NOT LOCAL.USER THEN _
  647.          STRNG$ = CARRIAGE.RETURN$ + SPACE$(CHARS.TO.WIPE) + CARRIAGE.RETURN$ : _
  648.          IF FOSSIL THEN _
  649.             BYTES% = LEN(STRNG$) : _
  650.             CALL FOSWRITE(COMPORT%,BYTES%,STRNG$) _
  651.          ELSE PRINT #3,STRNG$
  652.       IF SNOOP THEN _
  653.          LOCATE ,1 :  _
  654.          CALL LPRNT(SPACE$(CHARS.TO.WIPE),0) : _
  655.          LOCATE ,1
  656.       IF F7.MESSAGE$ = "" OR _
  657.          F7.MESSAGE$ = "NONE" OR _
  658.          NOT SYSOP.NEXT THEN _
  659.          EXIT SUB
  660.       BYPASS.TIME.CHECK = TRUE
  661.       CALL BUFFILE (F7.MESSAGE$,X)
  662.       END SUB
  663. ' $SUBTITLE: 'GETDIRS -- Prompt for directories to search'
  664. ' $PAGE
  665. '
  666. '  SUBROUTINE NAME    -- GETDIRS
  667. '
  668. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  669. '                            DIR.PROMPT$             BASE OF DIRECTORY PROMPT
  670. '                            SHOW.HELP               Whether to display help
  671. '                                                    on entry
  672. '   OUTPUT PARAMETERS --     B$
  673. '                            Q
  674. '  SUBROUTINE PURPOSE -- Prompt for directories to search
  675. '
  676.       SUB GETDIRS (SHOW.HELP) STATIC
  677.       IF SHOW.HELP THEN _
  678.          GOTO 58902
  679. 58900 A$ = DIR.PROMPT$
  680.       SUBROUTINE.PARAMETER = 1
  681.       CALL TGET
  682.       IF Q = 0 OR SUBROUTINE.PARAMETER = -1 THEN _
  683.          EXIT SUB
  684.       CALL ALLCAPS (B$(1))
  685.       IF B$(1) = "Q" THEN _
  686.          Q = 0 : _
  687.          EXIT SUB
  688.       A = INSTR("E+.E-.E.L.H.?.",B$(1)+".")
  689.       IF A = 0 THEN _
  690.          EXIT SUB
  691.       IF A > 8 THEN _
  692.          GOTO 58901
  693.       IF A = 7 THEN _
  694.          EXTENDED.OFF = NOT EXTENDED.OFF _
  695.       ELSE EXTENDED.OFF = (A > 3)
  696.       CALL QTPUT ("Extended directory display "+MID$("ON OFF",1-3*EXTENDED.OFF,3),1)
  697.       GOTO 58900
  698. 58901 IF A = 9 AND Q > 1 THEN _
  699.          Q = Q - 1 : _
  700.          FOR B = 1 TO Q : _
  701.             B$(B) = B$(B + 1) : _
  702.          NEXT : _
  703.          EXIT SUB
  704. 58902 FILE.NAME$ = DIRECTORY.PATH$ + DIRECTORY.PREFIX$ + _
  705.                     "." + DIRECTORY.EXTENTION$
  706.       GDEFAULT$ = MID$(" GC",GR + 1, 1)
  707.       CALL GRAPHIC (GDEFAULT$)
  708.       CALL BUFFILE (FILE.NAME$,X)
  709.       GOTO 58900
  710.       END SUB
  711. '
  712. ' $SUBTITLE: 'CONVDIRS -- Converts coded response to right directory'
  713. ' $PAGE
  714. '
  715. '  SUBROUTINE NAME    -- CONVDIRS
  716. '
  717. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  718. '                            STRT               ELEMENT TO BEGIN WITH
  719. '                            B$                 ARRAY TO CONVERT
  720. '                            Q                  LAST ELEMENT TO CONFERT
  721. '
  722. '   OUTPUT PARAMETERS --     B$                 CONVERTED DIRECTORY LIST
  723. '
  724. '  SUBROUTINE PURPOSE -- LET THE USER PUT IN A SHORT STANDARD STRING FOR A
  725. '                        DIRECTORY
  726. '
  727. '
  728. 58950 SUB CONVDIRS (STRT) STATIC
  729.       FOR I=STRT TO Q
  730.          CALL ALLCAPS (B$(I))
  731.          IF B$(I)="U" THEN _
  732.             B$(I) = UPLOAD.DIR.CHECK$
  733.          IF B$(I) = "A" THEN _
  734.             B$(I) = "ALL"
  735.       NEXT
  736.       END SUB
  737. ' $SUBTITLE: 'MUZAK - subroutine to PLAY MUSIC'
  738. ' $PAGE
  739. '
  740. '  SUBROUTINE NAME    -- MUZAK
  741. '
  742. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  743. '                                 1   PLAY CONSIDER YOURSELF(OPENING SCREEN)
  744. '                                 2   PLAY WALK RIGHT IN(NEW USERS)
  745. '                                 3   PLAY DRAGNET (SECURITY VIOLATION)
  746. '                                 4   PLAY GOODBYE CHARLIE (GOODBYE)
  747. '                                 5   PLAY TAPS (ACCESS DENIED)
  748. '                                 6   PLAY OOM PAH PAH (DOWNLOAD)
  749. '                                 7   PLAY THNKS FOR MEMORIES(UPLOAD)
  750. '
  751. '  OUTPUT PARAMETERS  -- NONE
  752. '
  753. '  SUBROUTINE PURPOSE -- PROVIDE SYSOP'S AND THE VISUALLY IMPARED WITH
  754. '                        AUDITORY FEEDBACK ON WHAT RBBS-PC IS DOING
  755. '
  756.       SUB MUZAK (PASSED.ARG) STATIC
  757. 59100 FF = PASSED.ARG
  758.       SUBROUTINE.PARAMETER = 0
  759.       IF (NOT SNOOP) OR (NOT MUSIC) OR LOCAL.USER.MODE THEN _
  760.          EXIT SUB
  761.       ON FF GOTO 59102,59104,59106,59108,59110,59112,59114
  762.       EXIT SUB
  763. 59102 '---[Introduction CONSIDER YOURSELF]---
  764.     LEC$ = "MBT180A4B-8B-8B-8B-2.G4A8F2"
  765.     PLAY "O2 X" + VARPTR$(LEC$)
  766.     EXIT SUB
  767. 59104 '---[New User WALK RIGHT IN]---
  768.     LEC1$ = "MBT180G4G4D2G8F+8F8E2A8B8"
  769.     LEC2$ = "C8C+8D8C8"
  770.     LEC3$ = "B4G2"
  771.     PLAY "O2 X" + VARPTR$(LEC1$) + "O3 X" + VARPTR$(LEC2$) + "O2 X" + VARPTR$(LEC3$)
  772.     EXIT SUB
  773. 59106 '---[Security Violation DRAGNET THEME]---
  774.      LEC$ = "MBT120C2D8E-4C2.C2D8E-4C4G-2."
  775.      PLAY "O2 X" + VARPTR$(LEC$)
  776.      EXIT SUB
  777. 59108 '---[Goodbye GOODBYE CHARLIE]---
  778.       LEC$ = "MBT180B-2.G2.F4D2."
  779.       PLAY "O2 X" + VARPTR$(LEC$)
  780.       EXIT SUB
  781. 59110 '---[Access Denied TAPS]---
  782.       LEC1$ = "MBT90F8A16"
  783.       LEC2$ = "C4."
  784.       LEC3$ = "A4F4C2.C8C16F2"
  785.       PLAY "O2 X" + VARPTR$(LEC1$) + "O3 X" + VARPTR$(LEC2$) + "O2 X" + VARPTR$(LEC3$)
  786.       EXIT SUB
  787. 59112 '---[Download OOM PAH PAH]---
  788.        LEC$ = "MBT180F4A4A4C4A4A4G4A4G4D2"
  789.        PLAY "O2 X" + VARPTR$(LEC$)
  790.        EXIT SUB
  791. 59114 '---[Upload THANKS FOR THE MEMORIES]---
  792.        LEC1$ = "MBT180C2."
  793.        LEC2$ = "A8G8F4D2"
  794.        PLAY "O3 X" + VARPTR$(LEC1$) + "O2 X" + VARPTR$(LEC2$)
  795.        END SUB
  796. ' $SUBTITLE: 'TWOBYTEDATE -- subroutine to put date in two bytes'
  797. ' $PAGE
  798. '
  799. '  SUBROUTINE NAME    -- TWOBYTEDATE
  800. '
  801. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  802. '                             YY       FOUR DIGIT YEAR (I.E. 1987)
  803. '                             MM       MONTH
  804. '                             DD       DAY
  805. '                           RESULT$    LOCATION TO PLACE THE RESULT
  806. '
  807. '  OUTPUT PARAMETERS  -- RESULT$       TWO BYTE COMPRESSED DATE FOR USE IN
  808. '                                      A RANDOM RECORD
  809. '
  810. '  SUBROUTINE PURPOSE -- COMPRESS AN Y,M,D DATE INTO TWO CHARACTERS
  811.       SUB TWOBYTEDATE (YY,MM,DD,RESULT$) STATIC
  812. 59200 RESULT$ = CHR$(((YY - 1980) * 2) OR - ((MM AND 8) <> 0)) + _
  813.                 CHR$((MM AND NOT 8) * 32 + DD)
  814.       END SUB
  815. ' $SUBTITLE: 'CSTRDATE -- subroutine to Compress STRing DATE'
  816. ' $PAGE
  817. '
  818. '  SUBROUTINE NAME    -- CSTRDATE
  819. '
  820. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  821. '                            STRNG$   String Date (mm-dd-yyyy)
  822. '
  823. '  OUTPUT PARAMETERS  --    RESULT$    TWO BYTE COMPRESSED DATE FOR USE IN
  824. '                                      A RANDOM RECORD
  825. '
  826. '  SUBROUTINE PURPOSE -- COMPRESS AN 8-CHARACTER DATE INTO TWO CHARACTERS
  827.       SUB CSTRDATE (STRNG$,RESULT$) STATIC
  828.       IF LEN(STRNG$) < 8 THEN _
  829.          EXIT SUB
  830.       YY = VAL(MID$(STRNG$,7))
  831.       MM = VAL(STRNG$)
  832.       DD = VAL(MID$(STRNG$,4))
  833.       CALL TWOBYTEDATE (YY,MM,DD,RESULT$)
  834.       END SUB
  835. ' $SUBTITLE: 'UNCDATE -- subroutine to UNCompress DATE'
  836. ' $PAGE
  837. '
  838. '  SUBROUTINE NAME    -- UNCDATE
  839. '
  840. '  INPUT PARAMETERS   --   PARAMETER      MEANING
  841. '                        COMPRESSED.DATE$ Date in 2 byte compressed form
  842. '
  843. '  OUTPUT PARAMETERS  --     YY           Year of compressed date
  844. '                            MM           Month of compressed date
  845. '                            DD           Day of compressed date
  846. '                        DISPLAY.DATE$    8 char display date (mm-dd-yyyy)
  847. '
  848. '  SUBROUTINE PURPOSE -- Uncompress a 2 char date to get Y,M,D & display
  849. '
  850.       SUB UNCDATE (COMPRESSED.DATE$,YY,MM,DD,DISPLAY.DATE$) STATIC
  851.       CALL GETYMD (COMPRESSED.DATE$,1,YY)
  852.       CALL GETYMD (COMPRESSED.DATE$,2,MM)
  853.       CALL GETYMD (COMPRESSED.DATE$,3,DD)
  854.       DISPLAY.DATE$ = RIGHT$("00" + MID$(STR$(MM),2),2) + _
  855.                       "-" + _
  856.                       RIGHT$("00" + MID$(STR$(DD),2),2) + _
  857.                       "-" + _
  858.                       RIGHT$(STR$(YY),2)
  859.       END SUB
  860. ' $SUBTITLE: 'GETYMD -- subroutine to unpack a two-byte date'
  861. ' $PAGE
  862. '
  863. '  SUBROUTINE NAME    -- GETYMD
  864. '
  865. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  866. '                          TWOBYTE$    PACKED TWO-BYTE DATE FIELD
  867. '                            YMD       1 = YEAR
  868. '                                      2 = MONTH
  869. '                                      3 = DAY
  870. '                           RESULT     LOCATION TO PLACE THE RESULT
  871. '
  872. '  OUTPUT PARAMETERS  -- RESULT        FOUR DIGIT RESULT OF UNPAKING THE DATE
  873. '
  874. '  SUBROUTINE PURPOSE -- UNPACK A COMPRESSED TWO-BYTE DATE FIELD
  875. '
  876.       SUB GETYMD (TWOBYTE$,YMD,RESULT) STATIC
  877.       ON YMD GOTO 59205,59210,59215
  878.       EXIT SUB
  879. 59205 RESULT = (ASC(TWOBYTE$)AND NOT 1) / 2 + 1980
  880.       EXIT SUB
  881. 59210 RESULT = FIX((ASC(MID$(TWOBYTE$,2)) / 32)) OR ((ASC(TWOBYTE$) AND 1) * 8)
  882.       EXIT SUB
  883. 59215 RESULT = ASC(MID$(TWOBYTE$,2)) AND NOT 224
  884.       END SUB
  885. ' $SUBTITLE: 'PERSFILE - subroutine to process requests for personal files'
  886. ' $PAGE
  887. '
  888. '  SUBROUTINE NAME    -- PERSFILE
  889. '
  890. '  INPUT PARAMETERS   --     PARAMETER           MEANING
  891. '                            PERSONAL.CAT$     CATEGORY IN DIR FOR CALLER
  892. '                            PERSONAL.LEN      # CHARS IN PERSONAL CATEGORY
  893. '  OUTPUT PARAMETERS  -- NONE UP DOWNLOADS
  894. '
  895. '  SUBROUTINE PURPOSE -- SHOW CALLER WHAT PERSONAL FILES HAVE FOR
  896. '                        DOWNLOADING, VERIFY AND PROCESS REQUESTS FOR
  897. '                        DOWNLOADS
  898. '
  899. 59300 SUB PERSFILE (PERSONAL.CAT$,DOWNLOAD.FLAG) STATIC
  900.       CALL FINDIT (PERSONAL.DIR$)
  901. 59302 IF NOT OK THEN _
  902.          CALL QTPUT ("No personal files available",1) : _
  903.          Q = 0 : _
  904.          EXIT SUB
  905.       L = 36 + MAX.DESC.LEN + PERSONAL.LEN
  906.       IF LOF(2) < L THEN _
  907.         OK = FALSE : _
  908.         GOTO 59302
  909.       B$(0) = ""
  910.       CLOSE 2
  911.       IF SHARE.IT THEN _
  912.          OPEN PERSONAL.DIR$ FOR RANDOM SHARED AS #2 LEN=L _
  913.       ELSE OPEN "R",2,PERSONAL.DIR$,L
  914.       FIELD #2,33 + MAX.DESC.LEN AS PART.TO.PRINT$, _
  915.                PERSONAL.LEN    AS PRIVATE.CAT$, _
  916.                1               AS PERSONAL.STATUS$, _
  917.                2               AS FILLER$
  918.       MAX.PRINT = PAGE.LENGTH - 1
  919.       NON.STOP = NON.STOP OR (PAGE.LENGTH < 1)
  920.       LAST.REC = LOF(2) / L
  921.       IF DOWNLOADING THEN _
  922.          DOWNLOADING = FALSE : _
  923.          PERS.INDEX = DOWNLOAD.FLAG : _
  924.          DOWNLOAD.FLAG = 0 : _
  925.          GOTO 59306
  926.       IF Q > 1 THEN _
  927.          FOR I = 2 TO Q : _
  928.             B$(I - 1) = B$(I) : _
  929.          NEXT : _
  930.          Q = Q - 1 : _
  931.          GOTO 59304
  932. 59303 A$ = "Download what: L)ist, * = new, or file(s)" + _
  933.            PRESS.ENTER.EXPERT$
  934.       SUBROUTINE.PARAMETER = 1
  935.       CALL TGET
  936.       IF SUBROUTINE.PARAMETER = -1 OR Q = 0 THEN _
  937.          EXIT SUB
  938. 59304 SELECTED.PROTOCOL$ = ""
  939.       IF Q > 1 THEN _
  940.          IF LEN(B$(Q)) = 1 THEN _
  941.             SELECTED.PROTOCOL$ = B$(Q) : _
  942.             Q = Q - 1
  943.       IF LEN(B$(1)) > 2 THEN _
  944.          GOTO 59330
  945.       CALL ALLCAPS (B$(1))
  946.       ON INSTR("L*",B$(1)) GOTO 59305,59327
  947.       GOTO 59303
  948. 59305 PERS.INDEX = LAST.REC
  949.       L = FALSE
  950. 59306 IF PERS.INDEX < 1 THEN _
  951.          IF L THEN _
  952.             GOTO 59303 _
  953.          ELSE _
  954.             A$ = "No files for you" : _
  955.                  CALL QTPUT (A$,1) : _
  956.               GOTO 59303
  957.       GET #2,PERS.INDEX
  958.       PERS.INDEX = PERS.INDEX - 1
  959.       IF SYSOP THEN _
  960.          GOTO 59320
  961.       IF ASC(PRIVATE.CAT$) = 32 THEN _
  962.          IF USER.SECURITY.LEVEL < VAL(PRIVATE.CAT$) THEN _
  963.             GOTO 59306 _
  964.          ELSE GOTO 59308
  965.       IF PERSONAL.CAT$ <> PRIVATE.CAT$ THEN _
  966.          GOTO 59306
  967. 59308 L = TRUE
  968.       FILNAME$ = PERSONAL.DRVPATH$ + _
  969.                  LEFT$(PART.TO.PRINT$,12)
  970. 59320 IF PERSONAL.STATUS$ = "*" THEN _
  971.          A$ = "*" + PART.TO.PRINT$ _
  972.       ELSE A$ = " " + PART.TO.PRINT$
  973.       CALL COLORDIR (A$,"N")
  974.       IF LOCAL.USER THEN _
  975.          GOTO 59322
  976.       CALL EOFCOMM (CHAR%)
  977.       IF CHAR% <> -1 THEN _
  978.          GOTO 59323            ' comm port input
  979. 59322 KEYBOARD.STACK$ = INKEY$
  980.       IF KEYBOARD.STACK$ = "" THEN _  ' no keyboard input
  981.          CALL QTPUT (A$,1) : _
  982.          GOTO 59324
  983. 59323 SUBROUTINE.PARAMETER = 1
  984.       CALL TPUT
  985.       IF RET THEN _
  986.          GOTO 59303
  987.       IF SUBROUTINE.PARAMETER = -1 THEN _
  988.          GOTO 59335
  989. 59324 IF LINES.PRINTED <= MAX.PRINT THEN _
  990.          GOTO 59306
  991.       CALL TIMEREMAIN (TIME.REMAINING!)
  992.       IF TIME.REMAINING! < 0.1 THEN _
  993.          SUBROUTINE.PARAMETER = -1 : _
  994.          GOTO 59335
  995.       CALL CARRIER
  996.       IF SUBROUTINE.PARAMETER = -1 THEN _
  997.          GOTO 59335
  998.       IF NON.STOP THEN _
  999.          GOTO 59306
  1000. 59325 IF PERS.INDEX > 0 THEN _
  1001.          A$ = "MORE: [Y],N,C or download what (* = new)" _
  1002.       ELSE GOTO 59303
  1003.       SUBROUTINE.PARAMETER = 1
  1004.       NO.ADVANCE = TRUE
  1005.       CALL TGET
  1006.       IF SUBROUTINE.PARAMETER = -1 THEN _
  1007.          GOTO 59335
  1008.       NON.STOP = (NON.STOP OR INSTR(" Cc",B$) > 1)
  1009.       IF PERS.INDEX < 1 AND Q = 0 THEN _
  1010.          GOTO 59335
  1011.       CALL WIPELINE (78)
  1012.       IF NO THEN _
  1013.          GOTO 59303
  1014.       IF LEN(B$(1)) > 2 THEN _
  1015.          GOTO 59304
  1016.       GOTO 59306
  1017. 59327 PERS.INDEX = LAST.REC        ' handle new files
  1018.       Q = 0
  1019.       WHILE PERS.INDEX > 0 AND  Q < UBOUND(B$)
  1020.          GET 2,PERS.INDEX
  1021.          IF PERSONAL.CAT$ <> PRIVATE.CAT$ THEN _
  1022.             GOTO 59329
  1023.          IF PERSONAL.STATUS$ <> "*" THEN _
  1024.             GOTO 59329
  1025.          Q = Q + 1
  1026.          I = Q
  1027.          GOSUB 59336
  1028.          IF OK THEN _
  1029.             X$ = MID$(STR$(PERS.INDEX),2) : _
  1030.             B$(0) = B$(0) + _
  1031.                     X$ + _
  1032.                     SPACE$(5 - LEN(X$)) _
  1033.          ELSE Q = Q - 1
  1034. 59329    PERS.INDEX = PERS.INDEX - 1
  1035.       WEND
  1036.       IF Q = 0 THEN _
  1037.          A$ = "No new files for you" : _
  1038.          CALL QTPUT (A$,1) : _
  1039.          GOTO 59303
  1040.       GOTO 59332
  1041. 59330 I = 1              ' handle list of files
  1042.       WHILE I <= Q
  1043.          OK = FALSE
  1044.          J = LAST.REC + 1
  1045.          CALL ALLCAPS (B$(I))
  1046.          WHILE J > 1 AND NOT OK
  1047.             J = J - 1
  1048.             GET #2,J
  1049.             IF (PERSONAL.CAT$ = PRIVATE.CAT$ OR _
  1050.                (ASC(PRIVATE.CAT$) = 32 AND _
  1051.                 USER.SECURITY.LEVEL => VAL(PRIVATE.CAT$))) THEN _
  1052.                    OK = (B$(I) = LEFT$(PART.TO.PRINT$,INSTR(PART.TO.PRINT$," ") - 1))
  1053.          WEND
  1054.          IF OK THEN _
  1055.             GOSUB 59336 : _
  1056.             IF OK THEN _
  1057.                X$ = MID$(STR$(J),2) : _
  1058.                B$(0) = B$(0) + _
  1059.                        X$ + _
  1060.                        SPACE$(5 - LEN(X$))
  1061.          IF NOT OK THEN _
  1062.             CALL QTPUT (B$(I) + " not found - omitted",1) : _
  1063.             FOR K = I + 1 TO Q : _
  1064.                B$(K - 1) = B$(K) : _
  1065.             NEXT : _
  1066.             Q = Q - 1 : _
  1067.             I = I - 1
  1068.          I = I + 1
  1069.       WEND
  1070.       IF Q = 0 THEN _
  1071.          GOTO 59303
  1072. 59332 DOWNLOAD.FLAG = PERS.INDEX          ' set protocol
  1073.       DOWNLOADING = TRUE
  1074.       B = 1
  1075.       IF SELECTED.PROTOCOL$ = "" THEN _
  1076.          IF PERSONAL.PROTOCOL$ <> " " THEN _
  1077.             SELECTED.PROTOCOL$ = PERSONAL.PROTOCOL$
  1078.       IF SELECTED.PROTOCOL$ <> "" THEN _
  1079.          Q = Q + 1 : _
  1080.          B$(Q) = SELECTED.PROTOCOL$
  1081.       EXIT SUB
  1082.  
  1083. 59335 CLOSE 2
  1084.       EXIT SUB
  1085. 59336 B$(I) = LEFT$(PART.TO.PRINT$,INSTR(PART.TO.PRINT$," ") - 1)
  1086.       CALL RBBSFIND (PERSONAL.DRVPATH$ + B$(I),Z,K,L,M)
  1087.       OK = (Z = 0)
  1088.       IF OK THEN _
  1089.          B$(I) = PERSONAL.DRVPATH$ + B$(I) _
  1090.       ELSE K = 0 : _
  1091.            WHILE K < SUBDIR.COUNT AND NOT OK : _
  1092.               K = K + 1 : _
  1093.               CALL RBBSFIND (SUBDIR$(K) + B$(I),Z,X,L,M) : _
  1094.               OK = (Z=0) : _
  1095.            WEND : _
  1096.            IF OK THEN _
  1097.               B$(I) = SUBDIR$(K) + B$(I)
  1098.       RETURN
  1099.       END SUB
  1100. ' $SUBTITLE: 'LOGDOWN -- subroutine to record private downloads'
  1101. ' $PAGE
  1102. '
  1103. '  SUBROUTINE NAME    -- LOGDOWN
  1104. '
  1105. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1106. '
  1107. '  OUTPUT PARAMETERS  --
  1108. '
  1109. '  SUBROUTINE PURPOSE -- PUTS A "!" IN PLACE OF AN "*" IN PRIVATE
  1110. '                        DIRECTORY AFTER DOWNLOADED
  1111. '
  1112. 59400 SUB LOGDOWN (PRIVATE.DOWNLOAD,DWN.INDEX) STATIC
  1113.       IF NOT PRIVATE.DOWNLOAD THEN _
  1114.          EXIT SUB
  1115.       EN$ = PERSONAL.DIR$
  1116.       BX = &H4
  1117.       SUBROUTINE.PARAMETER = 9
  1118.       CALL FILELOCK
  1119.       L = 36 + MAX.DESC.LEN + PERSONAL.LEN
  1120.       CLOSE 2
  1121.       IF SHARE.IT THEN _
  1122.          OPEN EN$ FOR RANDOM SHARED AS #2 LEN=L _
  1123.       ELSE OPEN "R",2,PERSONAL.DIR$,L
  1124.       FIELD #2,L AS PERSONAL.REC$
  1125.       A = VAL(MID$(B$(0),5 * (DWN.INDEX - 1) + 1,5))
  1126.       GET #2,A
  1127.       MID$(PERSONAL.REC$,L-2,1) = "!"
  1128.       PUT #2,A
  1129.       BX = &H4
  1130.       SUBROUTINE.PARAMETER = 10
  1131.       CALL FILELOCK
  1132.       CLOSE 2
  1133.       END SUB
  1134. ' $SUBTITLE: 'USERFACE - subroutine to handle programmable user interface'
  1135. ' $PAGE
  1136. '
  1137. '  SUBROUTINE NAME    --  USERFACE
  1138. '
  1139. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  1140. '                         GDEFAULT$            GRAPHICS DEFAULT TO USE
  1141. '                         CURRENT.PUI$         PUI TO USE
  1142. '                         EXPERT.USER          WHETHER CALL IN EXPERT MODE
  1143. '
  1144. '  OUTPUT PARAMETERS  --  Q
  1145. '                         B$()
  1146. '                         Z$
  1147. '
  1148. '  SUBROUTINE PURPOSE --  WHEN SYSOP OVERRIDES RBBS-PC's DEFAULT USER
  1149. '                         INTERFACE (PROVIDES A MAIN.PUI), THIS ROUTINE
  1150. '                         READS IN THE TABLE OF SPECIFICATIONS, PRESENTS
  1151. '                         THE SYSOP MENU, PRESENTS THE PROMPT, VERIFIES
  1152. '                         THAT A VALID OPTION HAS BEEN PICKED, DETERMINES
  1153. '                         WHETHER THE OPTION IS ANOTHER PUI, AND PASSES
  1154. '                         BACK CHOICES TO BE PROCESSED.
  1155. '
  1156. 59450 SUB USERFACE (GDEFAULT$) STATIC
  1157. 59455 IF PREV.PUI$ = CURRENT.PUI$ THEN _
  1158.          GOTO 59458
  1159. 59456 FILE.NAME$ = CURRENT.PUI$
  1160.       CALL GRAPHIC (GDEFAULT$)
  1161.       IF NOT OK THEN _
  1162.          CALL UPDTCALR ("Missing menu " + CURRENT.PUI$,2) : _
  1163.          CURRENT.PUI$ = PREV.PUI$ : _
  1164.          GOTO 59456
  1165.       PREV.PUI$ = CURRENT.PUI$
  1166.       LINE INPUT #2,FILE.NAME$
  1167.       LINE INPUT #2,PRMPT$
  1168.       INPUT #2,VALID.CHOICE$,ACTUAL.COMMANDS$
  1169.       LINE INPUT #2,MENU.CHOICE$
  1170.       LINE INPUT #2,MENU.NAME$
  1171.       LINE INPUT #2,QUIT.COMMAND$
  1172.       LINE INPUT #2,QUIT.PROMPT$
  1173.       LINE INPUT #2,QUIT.SUBCOMMANDS$
  1174.       LINE INPUT #2,QUIT.MENUOPT$
  1175.       LINE INPUT #2,QUIT.MENUS$
  1176.       CALL GRAPHIC (GDEFAULT$)
  1177.       CALL BRKFNAME (FILE.NAME$,MENU.DRVPATH$,X$,Y$,TRUE)
  1178.       MENU.TO.DISPLAY$ = FILE.NAME$
  1179.       J = INSTR(ORIG.COMMANDS$,"?")
  1180.       IF J < 1 THEN _
  1181.          X$ = "" _
  1182.       ELSE X$ = MID$(ALL.OPTS$,J,1)
  1183. 59458 IF EXPERT.USER THEN _
  1184.          GOTO 59461
  1185. 59460 CALL BUFFILE (MENU.TO.DISPLAY$,X)
  1186. 59461 A$ = PRMPT$
  1187.       TURBO.KEY = -TURBO.KEY.USER
  1188.       SUBROUTINE.PARAMETER = 1
  1189.       CALL TGET
  1190.       IF SUBROUTINE.PARAMETER = -1 OR FUNCTION.KEY <> 0 THEN _
  1191.          EXIT SUB
  1192.       IF Q = 0 THEN _
  1193.          GOTO 59458
  1194. 59462 Z$ = B$(1)
  1195.       CALL ALLCAPS (Z$)
  1196.       IN.MACRO = FALSE
  1197.       J = INSTR(VALID.CHOICE$,Z$)
  1198.       IF J < 1 THEN _
  1199.          IF NOT IN.MACRO THEN _
  1200.             CALL CHKMACRO (Z$,IN.MACRO) : _
  1201.             IF IN.MACRO THEN _
  1202.                GOTO 59462 _
  1203.             ELSE GOTO 59492 _
  1204.          ELSE GOTO 59492
  1205.       Z$ = MID$(ACTUAL.COMMANDS$,J,1)
  1206.       B$(1) = Z$
  1207.       J = INSTR(MENU.CHOICE$,Z$)
  1208.       IF J > 0 THEN _
  1209.          CURRENT.PUI$ = MID$(MENU.NAME$,1 + (J - 1) * 7,7) : _
  1210.          GOTO 59490
  1211.       IF Z$ = X$ THEN _
  1212.          GOTO 59460
  1213.       IF Z$ <> QUIT.COMMAND$ THEN _
  1214.          EXIT SUB
  1215.       IF Q > 1 THEN _
  1216.          Y = 2 : _
  1217.          GOTO 59480
  1218. 59470 A$ = QUIT.PROMPT$
  1219.       TURBO.KEY = -TURBO.KEY.USER
  1220.       CALL TGET
  1221.       IF SUBROUTINE.PARAMETER = -1 OR FUNCTION.KEY <> 0 THEN _
  1222.          EXIT SUB
  1223.       IF Q = 0 THEN _
  1224.          GOTO 59458
  1225.       Y = 1
  1226. 59480 Z$ = B$(Y)
  1227.       CALL ALLCAPS (Z$)
  1228.       J = INSTR(QUIT.SUBCOMMANDS$,Z$)
  1229.       IF J < 1 THEN _
  1230.          GOTO 59470
  1231.       J = INSTR(QUIT.MENUOPT$,Z$)
  1232.       IF J > 0 THEN _ 'quit to submenu
  1233.          CURRENT.PUI$ = MID$(QUIT.MENUS$,1 + (J - 1) * 7,7) : _
  1234.          GOTO 59490
  1235.       IF Q = 1 THEN _  'valid but not menu - send to RBBS
  1236.          Q = 2 : _
  1237.          B$(2) = B$(1) : _
  1238.          B$(1) = QUIT.COMMAND$
  1239.       EXIT SUB
  1240. 59490 CALL REMOVE (CURRENT.PUI$," ")
  1241.       CURRENT.PUI$ = MENU.DRVPATH$ + _
  1242.                      CURRENT.PUI$ + _
  1243.                      ".PUI"
  1244.       GOTO 59455
  1245. 59492 CALL QTPUT (Z$ + " not valid choice",1)
  1246.       GOTO 59460
  1247.       END SUB
  1248. ' $SUBTITLE: 'SUBMENU -- subroutine to process menus'
  1249. ' $PAGE
  1250. '
  1251. '  SUBROUTINE NAME    -- SUBMENU
  1252. '
  1253. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1254. '                        PASSED.PROMPT$  PROMPT TO DISPLAY
  1255. '                        CURRENT.MENU$   NOVICE MENU TO DISPLAY
  1256. '                        FRONT.OPT$      DRIVE/PATH/PREFIX OF FILE
  1257. '                                          NEEDED FOR TYPED OPTION
  1258. '                        BACK.OPT$       SUFFIX/EXTENSION OF FILE
  1259. '                                          NEEDED WITH TYPED OPTION
  1260. '                        RETURN.ON$      LETTERS CALLING PROGRAM WANTS
  1261. '                                          CONTROL ON
  1262. '                        GR.DEFAULT$     GRAPHICS DEFAULT TO USE
  1263. '                        VERIFY.IN.MENU  WHETHER VERIFY OPTION IS IN MENU
  1264. '                        ALL.MENU.OK     WHETHER CONTROL SHOULD RETURN
  1265. '                                          WHEN IN MENU
  1266. '                        ANS.INDEX       # OF COMMANDS IN TYPE AHEAD
  1267. '                        REQUIRE.IN.MENU WHETHER OPTION MUST BE IN MENU
  1268. '
  1269. '  OUTPUT PARAMETERS  -- Z$              OPTION PICKED
  1270. '                        FILE.NAME$      NAME OF FILE SUPPORTING OPTION
  1271. '
  1272. '
  1273. '  SUBROUTINE PURPOSE -- HANDLES MENUS - INCLUDING CONFERENCE, BULLETINS,
  1274. '                        DOORS, QUESTIONAIRES.  SUPPORTS SUB-MENUS (I.E.
  1275. '                        AN OPTION ON THE MENU THAT INVOKES ANOTHER MENU)
  1276. '
  1277. 59500 SUB SUBMENU (PASSED.PROMPT$,CURRENT.MENU$,FRONT.OPT$, _
  1278.                   BACK.OPT$,RETURN.ON$,GR.DEFAULT$,VERIFY.IN.MENU, _
  1279.                   ALL.MENU.OK,REQUIRE.IN.MENU) STATIC
  1280. 59510 FILE.NAME$ = CURRENT.MENU$
  1281.       CALL GRAPHIC (GR.DEFAULT$)
  1282.       CURRENT.MENU.VER$ = FILE.NAME$
  1283.       STOP.INTERRUPTS = FALSE
  1284.       IF ANS.INDEX > 1 THEN _
  1285.          Q = 1 : _
  1286.          GOTO 59530
  1287.       IF EXPERT.USER THEN _
  1288.          GOTO 59520
  1289. 59515 CALL BUFFILE (CURRENT.MENU.VER$,ANS.INDEX) 'show menu
  1290. 59520 A$ = PASSED.PROMPT$            'get response
  1291.       SUBROUTINE.PARAMETER = 1
  1292.       CALL TGET
  1293.       IF Q = 0 OR SUBROUTINE.PARAMETER = -1 THEN _
  1294.          EXIT SUB
  1295.       ANS.INDEX = 1
  1296.       LAST.INDEX = Q
  1297. 59530 Z$ = B$(ANS.INDEX)
  1298.       CALL ALLCAPS (Z$)
  1299.       IF INSTR(RETURN.ON$,Z$) THEN _  'check whether calling pgm wants
  1300.          EXIT SUB
  1301.       IF INSTR("LH?",Z$) THEN _       'check whether caller wants help
  1302.          GOTO 59515
  1303.       IF INSTR(Z$,".") > 0 THEN _
  1304.          GOTO 59545
  1305.       FILE.NAME$ = FRONT.OPT$ + _
  1306.                    Z$
  1307.       CALL BADFILE (FILE.NAME$,A)
  1308.       IF A > 1 THEN _
  1309.          GOTO 59547
  1310.       FILE.NAME$ = FILE.NAME$ + _
  1311.                    BACK.OPT$
  1312.       CALL GRAPHIC (GR.DEFAULT$)
  1313.       IF OK THEN _
  1314.          IF NOT REQUIRE.IN.MENU THEN _
  1315.             EXIT SUB _
  1316.          ELSE CALL WORDINFILE (CURRENT.MENU$,Z$,FOUND) : _
  1317.               IF FOUND THEN _
  1318.                  EXIT SUB _
  1319.               ELSE GOTO 59540
  1320.       IF NOT VERIFY.IN.MENU THEN _
  1321.          GOTO 59540
  1322.       CALL WORDINFILE (CURRENT.MENU$,Z$,FOUND)  'verify against menu itself
  1323.       IF FOUND THEN _
  1324.          IF ALL.MENU.OK THEN _
  1325.             EXIT SUB
  1326. 59540 X$ = FRONT.OPT$ + _
  1327.            Z$ + _
  1328.            ".MNU" 'check whether option is a menu
  1329.       FILE.NAME$ = X$
  1330.       CALL GRAPHIC (GR.DEFAULT$)
  1331.       IF OK THEN _
  1332.          CURRENT.MENU.VER$ = FILE.NAME$ : _
  1333.          CURRENT.MENU$ = X$ : _
  1334.          GOTO 59515
  1335.       IF VERIFY.IN.MENU AND FOUND AND NOT REQUIRE.IN.MENU THEN _
  1336.          CALL UPDTCALR("Option " + Z$ + " on menu " + _
  1337.                        CURRENT.MENU$ + " but not found",1)
  1338. 59545 IF INSTR(RETURN.ON$,LEFT$(Z$,1)) > 0 THEN _
  1339.          EXIT SUB
  1340. 59547 CALL QTPUT ("No such option " + Z$,1)
  1341.       GOTO 59515
  1342.       END SUB
  1343. ' $SUBTITLE: 'SETECHO -- subroutine to reset who echoes'
  1344. ' $PAGE
  1345. '
  1346. '  SUBROUTINE NAME    -- SETECHO
  1347. '
  1348. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1349. '                          NEW.ECHO$   The new echo option
  1350. '                          LOCAL.USER
  1351. '
  1352. '  OUTPUT PARAMETERS  -- REMOTE.ECHO   Whether RBBS is to echo what a
  1353. '                                      remote caller types
  1354. '
  1355. '  SUBROUTINE PURPOSE -- Resets who echos.  "R" is for RBBS to echo.
  1356. '                        "I" is for intermediate host to echo.
  1357. '                        "C" is for caller's communication pgm to echo.
  1358. '
  1359. 59600 SUB SETECHO (NEW.ECHO$) STATIC
  1360.       IF NEW.ECHO$ = PREV.ECHO$ THEN _
  1361.          EXIT SUB
  1362.       IF NEW.ECHO$ = "R" THEN _
  1363.          REMOTE.ECHO = (NOT LOCAL.USER) _
  1364.       ELSE REMOTE.ECHO = FALSE
  1365.       IF LOCAL.USER THEN _
  1366.          GOTO 59602
  1367.       IF NEW.ECHO$ = "I" THEN _
  1368.           IF FOSSIL THEN _
  1369.              BYTES% = LEN(HOST.ECHO.ON$) : _
  1370.              CALL FOSWRITE(COMPORT%,BYTES%,HOST.ECHO.ON$) : _
  1371.              GOTO 59602 _
  1372.           ELSE PRINT #3,HOST.ECHO.ON$; : _
  1373.                GOTO 59602
  1374.       IF PREV.ECHO$ = "I" THEN _
  1375.           IF FOSSIL THEN _
  1376.              BYTES% = LEN(HOST.ECHO.OFF$) : _
  1377.              CALL FOSWRITE(COMPORT%,BYTES%,HOST.ECHO.OFF$) _
  1378.           ELSE PRINT #3,HOST.ECHO.OFF$;
  1379. 59602 PREV.ECHO$ = NEW.ECHO$
  1380.       END SUB
  1381. ' $SUBTITLE: 'MIMPORT -- subroutine to import a message'
  1382. ' $PAGE
  1383. '
  1384. '  SUBROUTINE NAME    -- MIMPORT
  1385. '
  1386. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1387. '                          MAX.LINES     MAXIMUM # OF LINES
  1388. '                          MAX.LEN       MAXIMUM LENGTH OF A LINE
  1389. '                          NUM.LINES     NUMBER OF LINES ALREADY IN MESSAGE
  1390. '                          LINE.ARA$     ARRAY OF LINES IN MESSAGE
  1391. '
  1392. '  OUTPUT PARAMETERS       NUM.LINES
  1393. '                          LINE.ARA$
  1394. '
  1395. '  SUBROUTINE PURPOSE -- ALLOWS LOCAL USER TO APPEND A TEXT FILE TO
  1396. '                        A MESSAGE.   WILL WORD WRAP IF NECESSARY.
  1397. '
  1398.       SUB MIMPORT (MAX.LINES,MAX.LEN,NUM.LINES,LINE.ARA$(1)) STATIC
  1399.       IF NOT (LOCAL.USER OR SYSOP) THEN _
  1400.          CALL QTPUT ("Only for SYSOPS/local users",1) : _
  1401.          EXIT SUB
  1402. 59700 SUBROUTINE.PARAMETER = 1
  1403.       A$ = "Import what file" + PRESS.ENTER$
  1404.       CALL TGET
  1405.       IF SUBROUTINE.PARAMETER = -1 OR Q = 0 THEN _
  1406.          EXIT SUB
  1407.       CALL FINDIT (B$)
  1408.       IF NOT OK THEN _
  1409.          CALL QTPUT (B$ + " not found",1) : _
  1410.          GOTO 59700
  1411.       WHILE NOT EOF(2) AND NUM.LINES < MAX.LINES
  1412.          NUM.LINES = NUM.LINES + 1
  1413.          LINE INPUT #2,LINE.ARA$(NUM.LINES)
  1414.       WEND
  1415.       CLOSE 2
  1416.       CALL WORDWRAP (MAX.LEN,NUM.LINES,LINE.ARA$())
  1417.       END SUB
  1418. ' $SUBTITLE: 'WORDWRAP -- subroutine to wrap lines in a message'
  1419. ' $PAGE
  1420. '
  1421. '  SUBROUTINE NAME    -- WORDWRAP
  1422. '
  1423. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1424. '                          MAX.LEN       MAXIMUM LENGTH OF A SINGLE LINE
  1425. '                          NUM.LINES     NUMBER OF LINES IN A MESSAGE
  1426. '                          LINE.ARA$     ALL THE LINES IN THE MESSAGE
  1427. '
  1428. '  OUTPUT PARAMETERS       NUM.LINES
  1429. '                          LINE.ARA$
  1430. '
  1431. '  SUBROUTINE PURPOSE -- BATCH ADJUSTS A MESSAGE, WRAPPING LINES IF
  1432. '                        NEEDED.  PRESERVES PARAGRAPH STRUCTURE.
  1433. '
  1434.       SUB WORDWRAP (MAX.LEN,NUM.LINES,LINE.ARA$(1)) STATIC
  1435.       J = 1
  1436.       WHILE J <= NUM.LINES
  1437.          CALL TRIMTRAIL (LINE.ARA$(J)," ")
  1438.          K = LEN(LINE.ARA$(J))
  1439.          IF K <= MAX.LEN THEN _
  1440.             GOTO 59705
  1441.          CALL FINDLAST (LINE.ARA$(J)," ",LAST.POS,HOW.MANY)
  1442.          IF LEFT$(LINE.ARA$(J + 1),2) = "  " THEN _
  1443.             FOR K = NUM.LINES TO J + 1 STEP -1 : _
  1444.                LINE.ARA$(K + 1) = LINE.ARA$(K) : _
  1445.             NEXT : _
  1446.             NUM.LINES = NUM.LINES + 1 : _
  1447.             LINE.ARA$(J + 1) = ""
  1448.          IF LAST.POS < 1 THEN _
  1449.             LINE.ARA$(J + 1) = MID$(LINE.ARA$(J),MAX.LEN) + LINE.ARA$(J + 1) : _
  1450.             LINE.ARA$(J) = LEFT$(LINE.ARA$(J),MAX.LEN - 1) + "-" _
  1451.          ELSE B$ = LEFT$(" ", - (LEN(LINE.ARA$(J + 1)) > 0)) : _
  1452.               LINE.ARA$(J + 1) = MID$(LINE.ARA$(J),LAST.POS + 1) + B$ + LINE.ARA$(J + 1) : _
  1453.               LINE.ARA$(J) = LEFT$(LINE.ARA$(J),LAST.POS - 1)
  1454. 59705    J = J + 1
  1455.       WEND
  1456.       NUM.LINES = NUM.LINES - (LEN(LINE.ARA$(NUM.LINES + 1)) > 0)
  1457.       END SUB
  1458. ' $SUBTITLE: 'SETABORT -- subroutine to set a time-limit'
  1459. ' $PAGE
  1460. '
  1461. '  SUBROUTINE NAME    -- SETABORT
  1462. '
  1463. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1464. '                         SECONDS.TO.ADD # SECONDS AFTER CURRENT TIME
  1465. '                                        WHEN TIME LIMIT IS TO EXPIRE
  1466. '
  1467. '  OUTPUT PARAMETERS      ABORT.TIME!    THE TIME (IN SECONDS AFTER MIDNIGHT)
  1468. '                                           WHEN TIME LIMIT EXPIRES
  1469. '
  1470. '  SUBROUTINE PURPOSE -- SETS A TIME LIMIT IN UNITS OF SECONDS AFTER
  1471. '                        MIDNIGHT AFTER WHICH A TIME LIMIT WILL EXPIRE.
  1472. '                        CALLING PROGRAM PASSES NUMBER OF SECONDS THAT CAN
  1473. '                        ELASPE BEFORE TIME-LIMIT IS REACHED.
  1474. '
  1475. 59750 SUB SETABORT (ABORT.TIME!,SECONDS.TO.ADD) STATIC
  1476.       CALL FINDTIME (ABORT.TIME!)
  1477.       ABORT.TIME! = ABORT.TIME! + SECONDS.TO.ADD
  1478.       END SUB
  1479. ' $SUBTITLE: 'ANYBUT -- subroutine to find where a word begins'
  1480. ' $PAGE
  1481. '
  1482. '  SUBROUTINE NAME    -- ANYBUT
  1483. '
  1484. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1485. '                          STRNG$        STRING TO SEARCH FOR WORDS
  1486. '                          BEG%          BYTE POSITION IN STRNG$ TO
  1487. '                                           BEGIN SEARCHING
  1488. '                          SKIP.CHARS$   CHARACTERS TO SKIP OVER WHEN
  1489. '                                           SEARCHING
  1490. '
  1491. '  OUTPUT PARAMETERS       WHEREIS%      BYTES POSITION IN STRNG$ WHERE
  1492. '                                           WORD BEGINS
  1493. '
  1494. '  SUBROUTINE PURPOSE -- PARSER.   FINDS WHERE A "WORD" BEGINS, WHERE
  1495. '                        ANY CHARACTER WILL BE ACCEPTED AS THE BEGINNING OF A
  1496. '                        WORD EXCEPT THOSE LISTED IN SKIP.CHAR$
  1497. '
  1498. 59760 SUB ANYBUT (STRNG$, BEG%, SKIP.CHARS$, WHEREIS%) STATIC
  1499.       X$ = STRNG$ + _
  1500.            CHR$(0)
  1501.       WHEREIS% = BEG%
  1502.       IF WHEREIS% < 1 THEN _
  1503.          WHEREIS% = 1
  1504.       WHILE INSTR(SKIP.CHARS$, MID$(X$, WHEREIS%, 1)) > 0
  1505.          WHEREIS% = WHEREIS% + 1
  1506.       WEND
  1507.       IF WHEREIS% > LEN(STRNG$) THEN _
  1508.          WHEREIS% = 0
  1509.       END SUB
  1510. ' $SUBTITLE: 'FINDEND -- subroutine to find where a word ends'
  1511. ' $PAGE
  1512. '
  1513. '  SUBROUTINE NAME    -- FINDEND
  1514. '
  1515. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1516. '                          STRNG$        STRING TO SEARCH FOR WORDS
  1517. '                          BEG%          POSITION IN STRNG$ TO BEGIN SEARCH
  1518. '                          STOP.WITH$    CHARACTERS THAT TERMINATE A WORD
  1519. '
  1520. '  OUTPUT PARAMETERS       WHEREIS%      POSITION IN STRNG$ WHERE WORD ENDS
  1521. '                                        (I.E. THE LAST CHARACTER OF THE WORD)
  1522. '
  1523. '  SUBROUTINE PURPOSE -- PARSER.   FINDS WHERE A "WORD" ENDS, WHERE
  1524. '                        ANY CHARACTER WILL BE COUNTED AS IN A WORD
  1525. '                        EXCEPT FOR THOSE IN STOP.WITH$ OR WHEN THE END OF
  1526. '                        THE STRING IS FOUND.
  1527. '
  1528. 59770 SUB FINDEND (STRNG$, BEG%, STOP.WITH$, WHEREIS%) STATIC
  1529.       B = BEG%
  1530.       IF B < 1 THEN _
  1531.          B = 1
  1532.       IF B > LEN(STRNG$) THEN _
  1533.          X$ = STOP.WITH$ _
  1534.       ELSE X$ = MID$(STRNG$, B) + _
  1535.                 STOP.WITH$
  1536.       I = 1
  1537.       X = INSTR(STOP.WITH$, MID$(X$, I, 1))
  1538.       WHILE X = 0
  1539.          I = I + 1
  1540.          X = INSTR(STOP.WITH$, MID$(X$, I, 1))
  1541.       WEND
  1542.       WHEREIS% = I - 1 + B - 1
  1543.       END SUB
  1544. ' $SUBTITLE: 'GETALL -- subroutine to create directory list'
  1545. ' $PAGE
  1546. '
  1547. '  SUBROUTINE NAME    -- GETALL
  1548. '
  1549. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1550. '                          LOOK.IN$      NAME OF FILE TO SEARCH
  1551. '                          DIR.EXT$      MAIN DIRECTORY EXTENSION TO USE
  1552. '                          START.POS     LAST POSITION USED IN ARRAY
  1553. '
  1554. '  OUTPUT PARAMETERS       START.POS     LAST ELEMENT USED IN ARRAY
  1555. '                          LOAD.INTO$    ARRAY TO LOAD ELEMENTS FOUND
  1556. '
  1557. '  SUBROUTINE PURPOSE -- CREATES A LIST (LOAD.INTO$) OF ALL DIRECTORIES
  1558. '                        FOUND IN DIRECTORY OF DIRECTORIES (LOOK.IN$).
  1559. '                        USED FOR DETERMING WHAT GETS LISTED WHEN DOING
  1560. '                        AN "ALL" TO DETERMINATE WHAT SEPERATE DIRECTORIES
  1561. '                        TO DISPLAY.  DIRECTORY NAME MUST BE ALL CAPS
  1562. '                        AND FOLLOWED BY A SPACE OR DASH.
  1563. '
  1564. 59780 SUB GETALL (LOOK.IN$, LOAD.INTO$(1), DIR.EXT$, START.POS) STATIC
  1565.       IF MASTER.DIRECTORY.NAME$ <> "" THEN _
  1566.          START.POS = START.POS + 1 : _
  1567.          LOAD.INTO$(START.POS) = MASTER.DIRECTORY.NAME$ : _
  1568.          EXIT SUB
  1569.       CALL FINDIT(LOOK.IN$)
  1570.       IF NOT OK THEN _
  1571.          EXIT SUB
  1572.       MAX.LOAD = UBOUND(LOAD.INTO$, 1)
  1573.       START.SORT = START.POS + 1
  1574.       WHILE NOT EOF(2) AND START.POS < MAX.LOAD
  1575.          LINE INPUT #2, A$
  1576.          LAST.POS = LEN(A$)
  1577.          CALL ANYBUT(A$, 1, " ", X)
  1578.          WHILE X > 0 AND X < LAST.POS AND START.POS < MAX.LOAD
  1579.             CALL FINDEND(A$, X + 1, " -.", Y)
  1580.             L = Y - X + 1
  1581.             IF L > 8 THEN _
  1582.                GOTO 59782
  1583.             B$ = MID$(A$, X, L)
  1584.             IF B$ = "ALL" THEN _
  1585.                GOTO 59782
  1586.             CALL BADFILECHAR (B$,I)
  1587.             IF NOT I THEN _
  1588.                GOTO 59782
  1589.             Z$ = LEFT$(B$,1)
  1590.             IF (Z$ >= "0" AND Z$ <= "9") OR _
  1591.                (Z$ >= "A" AND Z$ <= "Z") THEN _
  1592.                   Z$ = B$ : _
  1593.                   CALL ALLCAPS (Z$) : _
  1594.                   IF Z$ = B$ THEN _
  1595.                      LOAD.INTO$(START.POS + 1) = Z$ : _
  1596.                      IF USE.DIR.ORDER THEN _
  1597.                         I = START.SORT : _
  1598.                         WHILE LOAD.INTO$(I) <> Z$ : _
  1599.                            I = I + 1 : _
  1600.                         WEND : _
  1601.                         START.POS = START.POS - (I > START.POS) _
  1602.                      ELSE _
  1603.                         I = START.SORT : _
  1604.                         Z = VAL(Z$) : _
  1605.                         WHILE VAL(LOAD.INTO$(I)) < Z : _
  1606.                            I = I + 1 : _
  1607.                         WEND : _
  1608.                         WHILE VAL(LOAD.INTO$(I)) = Z AND LOAD.INTO$(I) < Z$ AND I <= START.POS : _
  1609.                            I = I + 1 : _
  1610.                         WEND : _
  1611.                         IF I > START.POS THEN _
  1612.                            START.POS = I _
  1613.                         ELSE IF Z$ <> LOAD.INTO$(I) THEN _
  1614.                                 FOR J = START.POS TO I STEP -1 : _
  1615.                                    LOAD.INTO$(J + 1) = LOAD.INTO$(J) : _
  1616.                                 NEXT : _
  1617.                                 LOAD.INTO$(I) = Z$ : _
  1618.                                 START.POS = START.POS + 1
  1619. 59782       CALL ANYBUT(A$, Y + 1, " ", X)
  1620.          WEND
  1621.       WEND
  1622.       CLOSE 2
  1623.       END SUB
  1624. ' $SUBTITLE: 'FINDFILE -- subroutine to find a file'
  1625. ' $PAGE
  1626. '
  1627. '  SUBROUTINE NAME    --  FINDFILE
  1628. '
  1629. '  INPUT PARAMETERS   --  PARAMETER         MENANING
  1630. '                         FILNAME$         NAME OF FILE TO LOOK FOR
  1631. '                         FEXISTS          WHETHER FILE EXISTS
  1632. '
  1633. '  OUTPUT PARAMETERS  --  RETURNED.VALUE   VALUE RETURNED
  1634. '                                          TRUE  = FILE EXISTS
  1635. '                                          FALSE = FILE DOES NOT EXIST
  1636. '
  1637. '  SUBROUTINE PURPOSE --  DETERMINE WHETHER PASSED FILE FILNAME$ EXISTS
  1638. '                         UNLIKE, FINDIT, THIS ROUTINE DOES NOT OPEN ANY
  1639. '                         FILE AND, HENCE, DOES NOT CREATE ONE IN DETERMINIG
  1640. '                         IF A FILE EXISTS.
  1641. '
  1642. 59790 SUB FINDFILE (FILNAME$,FEXISTS) STATIC
  1643.       CALL BADFILECHAR (FILNAME$,FEXISTS)
  1644.       IF FEXISTS THEN _
  1645.          CALL RBBSFIND (FILNAME$,Z,Y,M,D) : _
  1646.          FEXISTS = (Z = 0)
  1647.       END SUB
  1648. ' $SUBTITLE: 'BADFILECHAR -- subroutine to check file for illegal char'
  1649. ' $PAGE
  1650. '
  1651. '  SUBROUTINE NAME    --  BADFILECHAR
  1652. '
  1653. '  INPUT PARAMETERS   --  PARAMETER         MEANING
  1654. '                         FILNAME$         NAME OF FILE TO CHECK
  1655. '
  1656. '  OUTPUT PARAMETERS  --  IS.OK            WHETHER NAME OK
  1657. '
  1658. '  SUBROUTINE PURPOSE --  Part of test for file's existence.  If bad
  1659. '                         character in name, can't exist.
  1660. '
  1661. 59800 SUB BADFILECHAR (FILNAME$,IS.OK) STATIC
  1662.      L = LEN(FILNAME$)
  1663.       X$ = FILNAME$ + "="
  1664.       I = 1
  1665.       WHILE INSTR("/[]|<>+=;,",MID$(X$,I,1)) = 0 AND ASC(MID$(X$,I)) < 128
  1666.          I = I + 1
  1667.       WEND
  1668.       IS.OK = I > L
  1669.       END SUB
  1670. '
  1671. ' $SUBTITLE: 'CONFMAIL -- subroutine to quickly check mail waiting'
  1672. ' $PAGE
  1673. '
  1674. '  SUBROUTINE NAME    -- CONFMAIL
  1675. '
  1676. '  INPUT PARAMETERS   -- PARAMETER        MEANING
  1677. '                    CONFMAIL.LIST$       File of user/message pairs to check
  1678. '                    ACTIVE.USER.FILE$    Active user file (restored on exit)
  1679. '                    ACTIVE.MESSAGE.FILE$ Active msg file (restored)
  1680. '  OUTPUT PARAMETERS  -- None
  1681. '
  1682. '  SUBROUTINE PURPOSE -- Quicking scans message header record to get
  1683. '                        last msg # and user record to get whether any
  1684. '                        new mail and last msg read, reports both, using
  1685. '                        highlighting if new mail to caller.
  1686. '
  1687. 59850 SUB CONFMAIL STATIC
  1688.       IF START.HASH = 1 AND USER.FILE.INDEX > 0 AND START.INDIV = 0 THEN _
  1689.          CALL FINDIT (CONFMAIL.LIST$) _
  1690.       ELSE OK = FALSE
  1691.       IF NOT OK THEN _
  1692.          EXIT SUB
  1693.       CALL SKIPLINE (1)
  1694.       CALL QTPUT ("Checking Message Bases since last on...",1)
  1695.       ANY.MAIL = FALSE
  1696.       STOP.INTERRUPTS = FALSE
  1697.       A1$ = ACTIVE.USER.FILE$
  1698.       M$ = ACTIVE.MESSAGE.FILE$
  1699.       TEMP.INDIV.VALUE$ = ""
  1700.       SUIX = USER.FILE.INDEX
  1701.       USER.RECORD.HOLD$ = USER.RECORD$
  1702.       OK = TRUE
  1703. 59852 IF EOF(2) OR NOT OK THEN _
  1704.          GOTO 59854
  1705.          CALL READANY
  1706.          ACTIVE.USER.FILE$ = A$
  1707.          CALL READANY
  1708.          IF EC > 0 THEN _
  1709.             GOTO 59854
  1710.          ACTIVE.MESSAGE.FILE$ = A$
  1711.          CALL FINDFILE (ACTIVE.USER.FILE$,OK)
  1712.          IF NOT OK THEN _
  1713.             GOTO 59854
  1714.          CALL OPENUSER (HIGHEST.USER.RECORD)
  1715.          FIELD 5, 128 AS USER.RECORD$
  1716.          CALL FINDFILE (ACTIVE.MESSAGE.FILE$,OK)
  1717.          IF NOT OK THEN _
  1718.             GOTO 59854
  1719.          CALL FINDUSER (ORIG.USER.NAME$,TEMP.INDIV.VALUE$,START.HASH,LEN.HASH,_
  1720.                         START.INDIV,LEN.INDIV,HIGHEST.USER.RECORD,_
  1721.                         FOUND,UFI,SL)
  1722.          IF NOT FOUND THEN _
  1723.             GOTO 59852
  1724.          CALL OPENMSG
  1725.          FIELD 1, 128 AS MESSAGE.RECORD$
  1726.          GET 1,1
  1727.          ANY.MAIL = TRUE
  1728.          X = CVI(MID$(USER.RECORD$,57,2))
  1729.          X = (X AND 512) > 0
  1730.          CALL BRKFNAME (ACTIVE.USER.FILE$,X$,Y$,Z$,FALSE)
  1731.          A = CVI(MID$(USER.RECORD$,51,2))
  1732.          B = VAL(LEFT$(MESSAGE.RECORD$,8))
  1733.          Z = (B - A)
  1734.          IF Z < 1 THEN _
  1735.             X = FALSE
  1736.          A$ = MID$(STR$((B>A)*Z),2)
  1737.          SL = LEN(A$)
  1738.          A$ = SPACE$(-(SL<3) * (3-SL)) + A$
  1739.          SL = LEN(Y$)
  1740.          Y$ = LEFT$(Y$,SL-1) + SPACE$(-(SL<8) * (8-SL))
  1741.          IF X THEN _
  1742.             X$ = EMPHASIZE.ON$ : _
  1743.             Z$ = EMPHASIZE.OFF$ _
  1744.          ELSE X$ = "" : _
  1745.               Z$ = ""
  1746.          A$ = Y$ + ": " + A$ + " new message(s) - " + _
  1747.               X$ + MID$("NoneSome",-4*X+1,4) + " to you" + Z$
  1748.          SUBROUTINE.PARAMETER = 5
  1749.          CALL TPUT
  1750.          CALL ASKMORE ("",TRUE,TRUE,X,TRUE)
  1751.       IF NOT RET THEN _
  1752.          GOTO 59852
  1753. 59854 ACTIVE.USER.FILE$ = A1$
  1754.       CALL OPENUSER (HIGHEST.USER.RECORD)
  1755.       FIELD 5, 128 AS USER.RECORD$
  1756.       IF (NOT RET) AND NOT ANY.MAIL THEN _
  1757.          CALL QTPUT ("No new personal mail",1)
  1758.       USER.FILE.INDEX = SUIX
  1759.       LSET USER.RECORD$ = USER.RECORD.HOLD$
  1760.       ACTIVE.MESSAGE.FILE$ = M$
  1761.       CALL OPENMSG
  1762.       FIELD 1, 128 AS MESSAGE.RECORD$
  1763.       GET 1,1
  1764.       END SUB
  1765. ' $SUBTITLE: 'ASKMORE -- subroutine to pause when possible screen full'
  1766. ' $PAGE
  1767. '
  1768. '  SUBROUTINE NAME    -- ASKMORE
  1769. '
  1770. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1771. '                          EXTRA.PRMPT$  STRING TO ADD TO MORE PROMPT AT END
  1772. '                          OVERWRITE     WHETHER TO WIPE AWAY PROMPT
  1773. '
  1774. '  OUTPUT PARAMETERS  --   B$()
  1775. '                          NO
  1776. '
  1777. '  SUBROUTINE PURPOSE -- DETERMINES WHETHER NEED TO PAUSE IF SCREEN FULL.
  1778. '                        AND, IF SO, ASKS THE APPROPRIATE QUESTION.  IF NON-
  1779. '                        STOP, AT LEAST CHECK FOR CARRIER PRESENT.
  1780. '
  1781.       SUB ASKMORE (EXTRA.PRMPT$, OVERWRITE, CHECK.LINES,ABORT.INDEX,CANT.INTERRUPT) STATIC
  1782.       IF CHECK.LINES THEN _
  1783.          X = -DISPLAY.AS.UNIT*UNIT.COUNT -(NOT DISPLAY.AS.UNIT)*LINES.PRINTED : _
  1784.          IF X < PAGE.LENGTH THEN _
  1785.             Q = 0 : _
  1786.             EXIT SUB
  1787.       IF ONE.STOP THEN _
  1788.          ONE.STOP = FALSE : _
  1789.          NON.STOP = TRUE : _
  1790.          GOTO 59860
  1791.       IF NON.STOP THEN _
  1792.          LINES.PRINTED = 0 : _
  1793.          NO = FALSE : _
  1794.          CALL CARRIER : _
  1795.          IF KEYBOARD.STACK$ = "" AND COMMPORT.STACK$ = "" THEN _
  1796.             EXIT SUB _
  1797.          ELSE NON.STOP = FALSE
  1798. 59860 CALL QTPUT (EMPHASIZE.OFF$,0)
  1799.       IF CANT.INTERRUPT THEN _
  1800.          TURBO.KEY = 2 : _
  1801.          A$ = "Press Any Key to continue" _
  1802.       ELSE A$ = MORE.PROMPT$ + EXTRA.PRMPT$ + LEFT$(">",-EXPERT.USER)
  1803.       X = LEN(A$) + 2
  1804.       NO.ADVANCE = OVERWRITE
  1805.       SUBROUTINE.PARAMETER = 1
  1806.       IF EXTRA.PRMPT$ = "" AND TURBO.KEY = 0 THEN _
  1807.          TURBO.KEY = -TURBO.KEY.USER
  1808.       CALL TGET
  1809.       TURBO.KEY = FALSE
  1810.       NON.STOP = NON.STOP OR (INSTR(" Cc",B$) > 1)
  1811.       CALL WIPELINE (X + LEN(B$))
  1812.       IF CANT.INTERRUPT THEN _
  1813.          NO = FALSE : _
  1814.          EXIT SUB
  1815.       IF INSTR(" Aa",B$) > 1 THEN _
  1816.          ABORT.INDEX = 32000
  1817.       IF NO THEN _
  1818.          KEYBOARD.STACK$ = "" : _
  1819.          COMMPORT.STACK$ = ""
  1820.       END SUB
  1821. ' $SUBTITLE: 'COMPDATE -- subroutine to compute elased days'
  1822. ' $PAGE
  1823. '
  1824. '  SUBROUTINE NAME    -- COMPDATE
  1825. '
  1826. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1827. '                            YY        YEAR
  1828. '                            MM        MONTH
  1829. '                            DD        DAY
  1830. '                           RESULT!    LOCATION TO PLACE THE RESULT
  1831. '
  1832. '  OUTPUT PARAMETERS  -- RESULT!       COMPUTE COMPUTATIONAL DATE
  1833. '
  1834. '  SUBROUTINE PURPOSE -- COMPUTES A COMPUTATIONAL DATE FROM YEAR, MONTH, DAY.
  1835. '                        RESULTS MAY BE USED TO COMPUTE THE NUMBER OF ELASPED
  1836. '                        DAYS BETWEEN TWO DATES.  YOU MAY PASS A 2 OR 4 DIGIT
  1837. '                        YEAR, BUT FOR MEANINGFUL RESULTS, BE CONSISTENT
  1838. '
  1839.       SUB COMPDATE (YY,MM,DD,RESULT!) STATIC
  1840.       IF MM < 1 OR MM > 12 THEN _
  1841.          MM = 1
  1842.       RESULT! = YY * 365.0 + _
  1843.                 INT((YY - 1) / 4) + _
  1844.                 (MM - 1) * 28 + _
  1845.                 VAL(MID$("000303060811131619212426",(MM - 1) * 2 + 1,2)) - _
  1846.                 ((MM > 2) AND ((YY MOD 4) = 0)) + _
  1847.                 DD
  1848.       END SUB
  1849. ' $SUBTITLE: 'EXPDATE -- subroutine to display expiration date'
  1850. ' $PAGE
  1851. '
  1852. '  SUBROUTINE NAME    -- EXPDATE
  1853. '
  1854. '  INPUT PARAMETERS   --   PARAMETER           MEANING
  1855. '                        REGISTRATION.DATE!    COMPUTATIONAL REGISTRATION DATE
  1856. '                        REGISTRATION.PERIOD   DAYS IN REGISTRATION PERIOD
  1857. '
  1858. '  OUTPUT PARAMETERS  -- EXP.DATE$             DISPLAYABLE EXPIRATION DATE
  1859. '
  1860. '  SUBROUTINE PURPOSE -- COMPUTES/CREATES A DISPALYABLE REGISTRATION
  1861. '                        EXPIRATION DATE USING REGISTRATION DATE AND DAYS IN
  1862. '                        REGISTRATION PERIOD.
  1863. '
  1864.       SUB EXPDATE (REGISTRATION.DATE!,REGISTRATION.PERIOD,EXP.DATE$) STATIC
  1865.       EXPIRE.DATE! = REGISTRATION.DATE! + REGISTRATION.PERIOD
  1866.       EXPIRE.YEAR! = INT((EXPIRE.DATE! - EXPIRE.DATE! / 1461) / 365)
  1867.       EXPIRE.DAY% = EXPIRE.DATE! - (EXPIRE.YEAR! * 365 + INT((EXPIRE.YEAR! -1)/4))
  1868.       EXPIRE.MONTH% = -((EXPIRE.YEAR! MOD 4)<>0) * _
  1869.                       (1 - (EXPIRE.DAY% > 31) - (EXPIRE.DAY% > 59) - _
  1870.                       (EXPIRE.DAY% > 90) - (EXPIRE.DAY% >120) - _
  1871.                       (EXPIRE.DAY% > 151) - (EXPIRE.DAY% > 181) - _
  1872.                       (EXPIRE.DAY% > 212) - (EXPIRE.DAY% > 243) - _
  1873.                       (EXPIRE.DAY% > 273) - (EXPIRE.DAY% > 304) - _
  1874.                       (EXPIRE.DAY% > 334)) - ((EXPIRE.YEAR! MOD 4) = 0) * _
  1875.                       (1 - (EXPIRE.DAY% > 31) - (EXPIRE.DAY% > 60) - _
  1876.                       (EXPIRE.DAY% > 91) - (EXPIRE.DAY% >121) - _
  1877.                       (EXPIRE.DAY% > 152) - (EXPIRE.DAY% > 182) - _
  1878.                       (EXPIRE.DAY% > 213) - (EXPIRE.DAY% > 243) - _
  1879.                       (EXPIRE.DAY% > 274) - (EXPIRE.DAY% > 305) - _
  1880.                       (EXPIRE.DAY% > 335))
  1881.       EXPIRE.DAY% = (EXPIRE.DAY% - ((EXPIRE.MONTH% - 1) * 28 + _
  1882.          VAL(MID$("000303060811131619212426",(EXPIRE.MONTH% -1) * 2 + 1,2)))) + _
  1883.          ((EXPIRE.MONTH% > 2) AND ((EXPIRE.YEAR! MOD 4) = 0))
  1884.       EXP.DATE$ = RIGHT$("0" + MID$(STR$(EXPIRE.MONTH%),2),2) + _
  1885.                   "/" + _
  1886.                   RIGHT$("0" + MID$(STR$(EXPIRE.DAY%),2),2) + _
  1887.                   "/" + _
  1888.                   RIGHT$(STR$(EXPIRE.YEAR!),2)
  1889.       END SUB
  1890. ' $SUBTITLE: 'COLORDIR - subroutine to build a color FMS directory string'        'RW060701
  1891. ' $PAGE                                                                           'RW060701
  1892. '                                                                                 'RW060701
  1893. '  SUBROUTINE NAME    --  COLORDIR                                                'RW060701
  1894. '                                                                                 'RW060701
  1895. '  INPUT PARAMETERS   --  PARAMETER                   MEANING                     'RW060701
  1896. '                         STRNG$              String to alter                     'RW060701
  1897. '                         FMS.DIR$            "Y" FOR FMS DIR                     'RW060701
  1898. '                                             "N" FOR PERSONAL DOWNLOADS          'RW060701
  1899. '                                                                                 'RW060701
  1900. 59920 SUB COLORDIR (STRNG$,FMS.DIR$) STATIC                                       'RW060701
  1901.       IF GR < 2 THEN _
  1902.          EXIT SUB
  1903.       IF FMS.DIR$ = "N" THEN _
  1904.          GOTO 59921
  1905. '
  1906. ' INSERT COLOR FOR FILENAME 
  1907. '
  1908.       ON INSTR("\ *",LEFT$(STRNG$,1)) GOTO 59924,59922,59923
  1909. 59921 STRNG$ = DR.1$ + LEFT$(STRNG$,13) + DR.2$ + MID$(STRNG$,14,10) + _
  1910.                DR.3$ + MID$(STRNG$,24,10) + DR.4$ + MID$(STRNG$,34,MAX.DESC.LEN)
  1911.       EXIT SUB
  1912. 59922 STRNG$ = DR.4$ + STRNG$
  1913.       EXIT SUB
  1914. 59923 STRNG$ = EMPHASIZE.OFF$ + STRNG$
  1915. 59924 END SUB
  1916. ' $SUBTITLE: 'CHKCOLOR - subroutine to highlight based on search string'
  1917. ' $PAGE
  1918. '
  1919. '  SUBROUTINE NAME    --  CHKCOLOR
  1920. '
  1921. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  1922. '                         LOOK.FOR$           String that triggers highlight
  1923. '                         LOOK.IN$            String being searched
  1924. '                         END.COLOR$          Terminating color
  1925. '
  1926. '  OUTPUT PARAMETERS  --  STRNG$              Revised string
  1927. '
  1928. '  SUBROUTINE PURPOSE --  Adds highlighting to a string within a string.
  1929. '                         Respects previous colorization.
  1930.       SUB CHKCOLOR (LOOK.IN$,LOOK.FOR$,PASSED.END.COLOR$) STATIC
  1931.       IF LOOK.FOR$ = "" THEN _
  1932.          EXIT SUB
  1933.       X$ = LOOK.IN$
  1934.       CALL ALLCAPS (X$)
  1935.       START.COLOR = INSTR(X$,LOOK.FOR$)
  1936.       IF START.COLOR < 1 THEN _
  1937.          EXIT SUB
  1938.       END.COLOR$ = PASSED.END.COLOR$
  1939.       IF END.COLOR$ = "" THEN _
  1940.          END.COLOR$ = EMPHASIZE.OFF$ : _
  1941.          CALL FINDLAST (LEFT$(LOOK.IN$,START.COLOR-1),ESCAPE$,WHERE.FOUND,J) : _
  1942.          IF WHERE.FOUND > 0 THEN _
  1943.             J = INSTR(WHERE.FOUND,LOOK.IN$,"m") : _
  1944.             IF J > 0 THEN _
  1945.                END.COLOR$ = MID$(LOOK.IN$,WHERE.FOUND,J-WHERE.FOUND+1)
  1946.       CALL BRACKET (LOOK.IN$,START.COLOR,START.COLOR + LEN(LOOK.FOR$)-1,EMPHASIZE.ON$,END.COLOR$)
  1947. '     CALL COLORIZE (LOOK.IN$,START.COLOR + LEN(LOOK.FOR$) - 1,START.COLOR,EMPHASIZE.ON$,END.COLOR$)
  1948.       END SUB
  1949. ' $SUBTITLE: 'SETHILITE - subroutine to reset highlight preference'
  1950. ' $PAGE
  1951. '
  1952. '  SUBROUTINE NAME    --  SETHILITE
  1953. '
  1954. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  1955. '                         SET.TO              New value (True or False)
  1956. '                         EMPHASIZE.ON.DEF$   String turns emphasize on
  1957. '                         EMPHASIZE.OFF.DEF$  String turns emphasize off
  1958. '
  1959. '  OUTPUT PARAMETERS  --  HIGHLIGHT.OFF       Callers preference on Hilite
  1960. '                         EMPHASIZE.ON$       String to use for emphasis
  1961. '                         EMPHASIZE.OFF$      String to use after emphasis
  1962. '
  1963.       SUB SETHILITE (SET.TO) STATIC
  1964.       HIGHLIGHT.OFF = (EMPHASIZE.ON.DEF$ <> "" AND SET.TO)
  1965.       IF HIGHLIGHT.OFF THEN _
  1966.          EMPHASIZE.ON$ = "" : _
  1967.          EMPHASIZE.OFF$ = "" : _
  1968.          FG.1$ = "" : _
  1969.          FG.2$ = "" : _
  1970.          FG.3$ = "" : _
  1971.          FG.4$ = "" _
  1972.       ELSE EMPHASIZE.ON$ = EMPHASIZE.ON.DEF$ : _
  1973.            FG.1$ = FG.1.DEF$ : _
  1974.            FG.2$ = FG.2.DEF$ : _
  1975.            FG.3$ = FG.3.DEF$ : _
  1976.            FG.4$ = FG.4.DEF$
  1977.       END SUB
  1978. ' $SUBTITLE: 'COLORPMT - subroutine to colorize prompts'
  1979. ' $PAGE
  1980. '
  1981. '  SUBROUTINE NAME    --  COLORPMT
  1982. '
  1983. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  1984. '                         STRNG$              String to colorize
  1985. '                         HIGHLIGHT.OFF       Whether highlighting is off
  1986. '                         EMPHASIZE.ON$       String to use for emphasis
  1987. '                         EMPHASIZE.OFF$      String to use after emphasis
  1988. '
  1989. '  OUTPUT PARAMETERS  --  STRNG$              Colorized string
  1990. '
  1991. '  SUBROUTINE PURPOSE -- colorizes a string based on sysop settings
  1992. '                        and the string.
  1993. '                        [...] is the default - put in emphasis
  1994. '                        <...> options to type - put in FG.4$
  1995. '                           and first two precedign words use FG.1$ and FG.2$
  1996. '                        options identified on right by ) and on
  1997. '                           left by space or comma - put in FG.4$
  1998. '
  1999.       SUB COLORPMT (STRNG$) STATIC
  2000.       IF HIGHLIGHT.OFF THEN _
  2001.          EXIT SUB
  2002.       ALREADY.COLORIZED = (INSTR(STRNG$,ESCAPE$) > 0)
  2003.       X = INSTR(STRNG$,"<")
  2004.       IF X > 0 THEN _
  2005.          GOTO 59943
  2006.       X = INSTR(STRNG$,"[")   ' highlight default
  2007.       IF X > 0 THEN _
  2008.          Y = INSTR(X,STRNG$,"]") : _
  2009.          IF Y > 0 THEN _
  2010.             CALL BRACKET (STRNG$,X,Y,EMPHASIZE.ON$,EMPHASIZE.OFF$)
  2011.       IF ALREADY.COLORIZED THEN _
  2012.          EXIT SUB
  2013.       X = INSTR(STRNG$,"<")
  2014.       IF X < 1 THEN _
  2015.          GOTO 59945
  2016. 59943 Y = INSTR(X,STRNG$,">")
  2017.       IF Y < 1 THEN _
  2018.          GOTO 59945
  2019.       CALL BRACKET (STRNG$,X,Y,FG.4$,EMPHASIZE.OFF$)
  2020.       Y = INSTR(STRNG$," ")
  2021.       IF Y > 1 AND Y < X THEN _
  2022.          STRNG$ = FG.1$ + STRNG$ : _
  2023.          Z = INSTR(Y+1,STRNG$," ") : _
  2024.          IF Z > 1 AND Z < X+LEN(FG.1$) THEN _
  2025.             STRNG$ = LEFT$(STRNG$,Z) + FG.2.DEF$ + MID$(STRNG$,Z+1)
  2026.       EXIT SUB
  2027. 59945 X = 1
  2028.       DID.INSERT = FALSE
  2029.       L = LEN(FG.4$)
  2030. 59950 Y = INSTR (X,STRNG$,")")  ' x: where command begins, y: terminating pos
  2031.       Z = INSTR (X,STRNG$,",")
  2032.       IF Y = 0 OR (Z > 0 AND Z < Y) THEN _
  2033.          Y = Z
  2034.       K = LEN(STRNG$)
  2035.       IF X > K THEN _
  2036.          EXIT SUB
  2037.       IF Y < 1 THEN _
  2038.          IF NOT DID.INSERT THEN _
  2039.             EXIT SUB _
  2040.          ELSE Y = K+1
  2041.       Z = Y - 1
  2042.       WHILE Z > 0    ' got terminating pos: find beginning
  2043.          IF INSTR(OPTION.END$,MID$(STRNG$,Z,1)) > 0 THEN _
  2044.             X = Z + 1 : _
  2045.             Z = 0
  2046.          Z = Z - 1
  2047.       WEND
  2048.       IF Y-X < 3 THEN _     ' exclude commands too long
  2049.          CMND.STRNG$ = MID$(STRNG$,X,Y-X) : _
  2050.          X$ = CMND.STRNG$ : _
  2051.          CALL ALLCAPS (CMND.STRNG$) : _
  2052.          IF X$ = CMND.STRNG$ THEN _  ' exclude lower case
  2053.             DID.INSERT = TRUE : _
  2054.             CALL BRACKET (STRNG$,X,Y-1,FG.4$,EMPHASIZE.OFF$) : _  ' colorize
  2055.             Y = Y + L
  2056.       X = Y + 1
  2057.       GOTO 59950
  2058.       END SUB
  2059. ' $SUBTITLE: 'BRACKET - Inserts strings around a string'
  2060. ' $PAGE
  2061. '
  2062. '  SUBROUTINE NAME    --  BRACKET
  2063. '
  2064. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2065. '                         STRNG$              Insert in this string
  2066. '                         B4.HERE             Insert 1st before this pos
  2067. '                         AFTER.HERE          Insert 2nd after this pos
  2068. '                         B4.STRNG$           String to insert before
  2069. '                         AFTER.STRNG$        String to insert after
  2070. '
  2071. '  OUTPUT PARAMETERS  --  STRNG$
  2072. '
  2073. '  SUBROUTINE PURPOSE -- Primarily for colorization
  2074. '
  2075.       SUB BRACKET (STRNG$,B4.HERE,AFTER.HERE,B4.STRNG$,AFTER.STRNG$) STATIC
  2076.       STRNG$ = LEFT$(STRNG$,B4.HERE-1) + _
  2077.                B4.STRNG$ + _
  2078.                MID$(STRNG$,B4.HERE,AFTER.HERE-B4.HERE+1) + _
  2079.                AFTER.STRNG$ + _
  2080.                RIGHT$(STRNG$,LEN(STRNG$) - AFTER.HERE)
  2081.       END SUB
  2082. ' $SUBTITLE: 'USERCOLOR - lets user set color for normal text'
  2083. ' $PAGE
  2084. '
  2085. '  SUBROUTINE NAME    --  USERCOLOR
  2086. '
  2087. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2088. '                         EMPHASIZE.OFF$      Normal text color
  2089. '
  2090. '  OUTPUT PARAMETERS  --  EMPHASIZE.OFF$      New text color
  2091. '                         BOLD.TEXT$          Whether bold (0 not, 1 bold)
  2092. '                         USER.TEXT.COLOR     ANSI Color selected
  2093. '
  2094. '  SUBROUTINE PURPOSE -- Lets caller select desired color and whether
  2095. '                        bold.
  2096.       SUB USERCOLOR STATIC
  2097.       IF HIGHLIGHT.OFF THEN _
  2098.          EXIT SUB
  2099. 59970 CALL QTPUT (EMPHASIZE.OFF$,0)
  2100.       A$ = "Make text R)ed,G)reen,Y)ellow,B)lue,P)urple,C)yan,W)hite" + PRESS.ENTER.EXPERT$
  2101.       GOSUB 59973
  2102.       IF Q = 0 THEN _
  2103.          EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + _
  2104.              ";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m" : _
  2105.          EXIT SUB
  2106.       CALL ALLCAPS (B$)
  2107.       X = INSTR("RGYBPCW",B$)
  2108.       IF X = 0 THEN _
  2109.          GOTO 59970
  2110.       USER.TEXT.COLOR = 30 + X
  2111.       A$ = "Make text BOLD (Y,[N])"
  2112.       GOSUB 59973
  2113.       BOLD.TEXT$ = CHR$(48 - YES)
  2114.       EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + ";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m"
  2115.       GOTO 59970
  2116. 59973 SUBROUTINE.PARAMETER = 1
  2117.       TURBO.KEY = -TURBO.KEY.USER
  2118.       CALL TGET
  2119.       IF SUBROUTINE.PARAMETER = -1 THEN _
  2120.          EXIT SUB
  2121.       RETURN
  2122.       END SUB
  2123. ' $SUBTITLE: 'SETUGD - Sets user graphic preference'
  2124. ' $PAGE
  2125. '
  2126. '  SUBROUTINE NAME    --  SETUGD
  2127. '
  2128. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2129. '                        GRAPHICS.NUMBER   0=None, 1=Ascii, 2=color
  2130. '
  2131. '  OUTPUT PARAMETERS  -- GR                Shared var - set to
  2132. '                                            graphics.number
  2133. '                        GRAPHICS.LETTER$  What add to file name to
  2134. '                                            see if got graphics file ver
  2135. '
  2136. '  SUBROUTINE PURPOSE -- Sets file graphics preference
  2137. '
  2138.       SUB SETUGD (GRAPHICS.NUMBER,GRAPHICS.LETTER$) STATIC
  2139.       GR = GRAPHICS.NUMBER
  2140.       IF GR = 2 THEN _
  2141.          DR.1$ = FG.1.DEF$ : _
  2142.          DR.2$ = FG.2.DEF$ : _
  2143.          DR.3$ = FG.3.DEF$ : _
  2144.          DR.4$ = FG.4.DEF$ _
  2145.       ELSE DR.1$ = "" : _
  2146.            DR.2$ = "" : _
  2147.            DR.3$ = "" : _
  2148.            DR.4$ = "" 
  2149.       GRAPHICS.LETTER$ = MID$(" GC",GR+1, - (GR > 0))
  2150.       END SUB
  2151. ' $SUBTITLE: 'EOFCOMM - Determines whether input in comm port buffer'
  2152. ' $PAGE
  2153. '
  2154. '  SUBROUTINE NAME    --  EOFCOMM
  2155. '
  2156. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2157. '                         FOSSIL              Whether fossil driver used
  2158. '                         COMPORT%            Comm port # in use
  2159. '
  2160. '  OUTPUT PARAMETERS  --  NOCHARS%           -1 (TRUE) if no chars in buffer.
  2161. '                                             Anything else means has char.
  2162. '
  2163. '  SUBROUTINE PURPOSE -- Query comm port to see if input waiting
  2164. '
  2165. 60000 SUB EOFCOMM (NOCHARS%) STATIC
  2166.       IF FOSSIL THEN _
  2167.          CALL FOSREADAHEAD(COMPORT%,NOCHARS%) _
  2168.       ELSE NOCHARS% = EOF(3)
  2169.       END SUB
  2170. ' $SUBTITLE: 'GSANDR - Global search and replace'
  2171. ' $PAGE
  2172. '
  2173. '  SUBROUTINE NAME    --  GSANDR
  2174. '
  2175. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2176. '                         STRNG$              String to edit
  2177. '                         LOOK.FOR$           String to look for
  2178. '                         REPLACE.BY$         String to replace by
  2179. '
  2180. '  OUTPUT PARAMETERS  --  STRNG$              Edited string
  2181. '
  2182. '  SUBROUTINE PURPOSE --  Replaces every occurence of LOOK.FOR$ that
  2183. '                         is in STRNG$ by REPLACE.BY$
  2184. '
  2185. 60100 SUB GSANDR (STRNG$,LOOK.FOR$,REPLACE.BY$) STATIC
  2186.       IF LOOK.FOR$ = "" THEN _
  2187.          EXIT SUB
  2188.       X = 1
  2189.       L = LEN(REPLACE.BY$)
  2190.       M = LEN(LOOK.FOR$)
  2191. 60102 Y = INSTR(X,STRNG$,LOOK.FOR$)
  2192.       IF Y < 1 THEN _
  2193.          EXIT SUB
  2194.       STRNG$ = LEFT$(STRNG$,Y-1) + _
  2195.                REPLACE.BY$ + _
  2196.                RIGHT$(STRNG$,LEN(STRNG$)-Y+1-M)
  2197.       X = Y + L
  2198.       IF X > LEN(STRNG$) THEN _
  2199.          EXIT SUB
  2200.       GOTO 60102
  2201.       END SUB
  2202. ' $SUBTITLE: 'METAGSR -- Meta Global search and replace'
  2203. ' $PAGE
  2204. '
  2205. '  SUBROUTINE NAME    --  METAGSR
  2206. '
  2207. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2208. '                         STRNG$              String to edit
  2209. '
  2210. '  OUTPUT PARAMETERS  --  STRNG$              Edited string
  2211. '
  2212. '  SUBROUTINE PURPOSE --  Sets up the file transfer META statements
  2213. '
  2214.       SUB METAGSR (STRNG$) STATIC
  2215.       IF BATCH.TRANSFER THEN _
  2216.          CALL GSANDR (STRNG$,"[FILE]","@"+NODE.WORK.FILE$) _
  2217.       ELSE CALL GSANDR (STRNG$,"[FILE]",FILE.NAME$)
  2218.       CALL GSANDR (STRNG$,"[BAUD]",TALK.TO.MODEM.AT$)
  2219.       CALL GSANDR (STRNG$,"[PORT]",COM.PORT$)
  2220.       CALL GSANDR (STRNG$,"[PORT#]",MID$(COM.PORT$,4))
  2221.       CALL GSANDR (STRNG$,"[PARITY]",MID$(BAUD.PARITY$,INSTR(BAUD.PARITY$,",")+1,1))
  2222.       CALL GSANDR (STRNG$,"[PROTO]",FT$)
  2223.       CALL GSANDR (STRNG$,"[NODE]",NODE.ID$)
  2224.       I = 1
  2225.       X$ = "[1]"
  2226.       WHILE INSTR(STRNG$,X$) > 0
  2227.          CALL GSANDR (STRNG$,X$,A$(I))
  2228.          I = I + 1
  2229.          X$ = "["+MID$(STR$(I),2)+"]"
  2230.       WEND
  2231.       END SUB
  2232. ' $SUBTITLE: 'TIMELOCK - Test TIME LOCK for premium features'
  2233. ' $PAGE
  2234. '
  2235. '  SUBROUTINE NAME    --  TIMELOCK  (written by Doug Azzarito)
  2236. '
  2237. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2238. '                         TIME.LOCK.SET               SECONDS/SESSION TO LOCK
  2239. '
  2240. '  OUTPUT PARAMETERS  --  SUBROUTINE.PARAMETER     -1 if feature is LOCKED
  2241. '
  2242. '  SUBROUTINE PURPOSE -- Check elapsed time for lock duration
  2243. '
  2244. 60150 SUB TIMELOCK STATIC
  2245.       CALL TIMEREMAIN(TIME.REMAINING!)
  2246.       IF TCA! > TIME.LOCK.SET THEN _
  2247.          OK = TRUE : _
  2248.          EXIT SUB
  2249.       CALL BUFFILE(HELP.PATH$+"TIMELOCK"+HELP.EXTENSION$,X)
  2250.       IF NOT OK THEN _
  2251.          CALL QTPUT("Sorry, " + FIRST.NAME$ + _
  2252.                     ", function unavailable for first" + _
  2253.                     STR$(TIME.LOCK.SET) + "seconds",1)
  2254.       OK = FALSE
  2255.       END SUB
  2256. ' $PAGE
  2257. '
  2258. '  SUBROUTINE NAME    --  MARKTIME
  2259. '
  2260. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2261. '                         DOT.NUMBER          How many dots printed
  2262. '
  2263. '  OUTPUT PARAMETERS  --  DOT.NUMBER
  2264. '
  2265. '  SUBROUTINE PURPOSE --  Marks time by putting colorized dots out
  2266. '                         to 4, then erasing
  2267. '
  2268. 60200 SUB MARKTIME (DOT.NUMBER) STATIC
  2269.       CALL FINDTIME (TI!)
  2270.       IF TI! - PREV.TI! < 1.0 THEN _
  2271.          EXIT SUB
  2272.       PREV.TI! = TI!
  2273.       IF REMOVE.DOT AND DOT.NUMBER > 0 THEN _
  2274.          CALL QTPUT (BACKSPACE$,0) : _
  2275.          DOT.NUMBER = DOT.NUMBER - 1 : _
  2276.          EXIT SUB
  2277.       DOT.NUMBER = DOT.NUMBER + 1
  2278.       ON DOT.NUMBER GOTO 60201,60202,60203,60204
  2279. 60201 X$ = FG.1$
  2280.       REMOVE.DOT = FALSE
  2281.       GOTO 60205
  2282. 60202 X$ = FG.2$
  2283.       GOTO 60205
  2284. 60203 X$ = FG.3$
  2285.       GOTO 60205
  2286. 60204 X$ = FG.4$
  2287.       REMOVE.DOT = TRUE
  2288. 60205 CALL QTPUT (X$ + "." + EMPHASIZE.OFF$,0)
  2289.       END SUB
  2290. ' $SUBTITLE: 'AUTOPAGE - NOTIFIES SYSOP WHEN SPECIFIC USER CALLS'
  2291. ' $PAGE
  2292. '
  2293. '  SUBROUTINE NAME   --  AUTOPAGE   'Contributed  by Gregg and Bob Snyder
  2294. '                                   'and RoseMarie Siddiqui
  2295. '
  2296. '  INPUT PARAMETERS  --  AUTOPAGE.DEF$  List of conditions that trigger
  2297. '                                       notification and how
  2298. '
  2299. '  OUTPUT PARAMETERS  -- NONE
  2300. '
  2301. '  SUBROUTINE PURPOSE -- Search AUTOPAGE.DEF$ for match on whether
  2302. '                        on name, security level, whether new user.
  2303. '                        Also controls whether caller notified and
  2304. '                        number of times sysop has bell rung.
  2305. '                        And what tune to play (if any).
  2306. '
  2307. 60300 SUB AUTOPAGE STATIC
  2308.       CALL FINDIT (AUTOPAGE.DEF$)
  2309.       IF NOT OK THEN _
  2310.          EXIT SUB
  2311.       EC = 0
  2312.       OK = FALSE
  2313.       WHILE NOT EOF(2) AND OK = FALSE AND EC = 0
  2314.          CALL READPARMS (WORK.ARA$(),4,1)
  2315.          IF EC = 0 THEN _
  2316.             OK = (WORK.ARA$(1) = ACTIVE.USER.NAME$) : _
  2317.             IF NOT OK THEN _
  2318.                IF NEW.USER AND WORK.ARA$(1) = "NEWUSER" THEN _
  2319.                   OK = TRUE _
  2320.                ELSE IF LEFT$(WORK.ARA$(1),1) = "/" AND LEN(WORK.ARA$(1)) > 2 THEN _
  2321.                        B = INSTR (2,WORK.ARA$(1),"/") : _
  2322.                        IF B > 0 AND LEN(WORK.ARA$(1)) > B THEN _
  2323.                           IF USER.SECURITY.LEVEL <= VAL(MID$(WORK.ARA$(1),B+1)) AND _
  2324.                              USER.SECURITY.LEVEL >= VAL(MID$(WORK.ARA$(1),2)) THEN _
  2325.                                 OK = TRUE
  2326.       WEND
  2327.       CLOSE 2
  2328.       IF NOT OK THEN _
  2329.          EXIT SUB
  2330.       PAGE.STATUS$ = "AutoPaged!"
  2331.       IF LEFT$(WORK.ARA$(2),1) = "N" THEN _
  2332.          A$ = "Sysop asked to be notified of your presence" : _
  2333.          CALL RINGCALLER
  2334.       B = (WORK.ARA$(4) = "")
  2335.       WORK.ARA$(5) = ""
  2336.       FOR I = 1 TO VAL(WORK.ARA$(3))
  2337.          IF B THEN _
  2338.             CALL PSCRN (BELL.RINGER$) _
  2339.          ELSE WORK.ARA$(5) = WORK.ARA$(5) + "O4 X" + VARPTR$(WORK.ARA$(4))
  2340.       NEXT
  2341.       IF NOT B THEN _
  2342.          PLAY WORK.ARA$(5)
  2343.       END SUB
  2344. ' $SUBTITLE: 'PUTMATTR - subroutine to save msg. attributes'
  2345. ' $PAGE
  2346. '
  2347. '  SUBROUTINE NAME    --  PUTMATTR
  2348. '
  2349. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2350. '                         Q
  2351. '                         B$
  2352. '                         LINES.IN.MESSAGE
  2353. '                         S
  2354. '                         NON.STOP
  2355. '                         MESSAGE.DIM.INDEX
  2356. '
  2357. '  OUTPUT PARAMETERS  --  SQ
  2358. '                         LG$(10)
  2359. '                         LINES.IN.MESSAGE.SAVE
  2360. '                         SL
  2361. '                         NON.STOP.SAVE
  2362. '                         MESSAGE.DIM.INDEX.SAVE
  2363. '
  2364. '  SUBROUTINE PURPOSE --  WHEN REPLYING TO A MESSAGE THIS ROUTINE SAVES
  2365. '                         THE ATTRIBUTES OF THE ORGINAL MESSAGE
  2366. '
  2367. 62520 SUB PUTMATTR STATIC
  2368.       SQ = Q
  2369.       LG$(10) = B$
  2370.       LINES.IN.MESSAGE.SAVE = LINES.IN.MESSAGE
  2371.       SL = S
  2372.       NON.STOP.SAVE = NON.STOP
  2373.       MESSAGE.DIM.INDEX.SAVE = MESSAGE.DIM.INDEX
  2374.       END SUB
  2375. ' $SUBTITLE: 'GETMATTR - subroutine to get msg. attributes'
  2376. ' $PAGE
  2377. '
  2378. '  SUBROUTINE NAME    --  GETMATTR
  2379. '
  2380. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2381. '                         SQ
  2382. '                         LG$(10)
  2383. '                         LINES.IN.MESSAGE.SAVE
  2384. '                         SL
  2385. '                         NON.STOP.SAVE
  2386. '                         MESSAGE.DIM.INDEX.SAVE
  2387. '
  2388. '  OUTPUT PARAMETERS  --  Q
  2389. '                         B$
  2390. '                         LINES.IN.MESSAGESAVE
  2391. '                         S
  2392. '                         NON.STOP
  2393. '                         MESSAGE.DIM.INDEX
  2394. '                         KILL.MESSAGE
  2395. '
  2396. '  SUBROUTINE PURPOSE --  AFTER REPLYING TO A MESSAGE THIS ROUTINE RESTORES
  2397. '                         THE ATTRIBUTES OF THE ORGINAL MESSAGE
  2398. '
  2399. 62530 SUB GETMATTR STATIC
  2400.       Q = SQ
  2401.       B$ = LG$(10)
  2402.       LINES.IN.MESSAGE = LINES.IN.MESSAGE.SAVE
  2403.       S = SL
  2404.       NON.STOP = NON.STOP.SAVE
  2405.       MESSAGE.DIM.INDEX = MESSAGE.DIM.INDEX.SAVE
  2406.       KILL.MESSAGE = FALSE
  2407.       END SUB
  2408. ' $SUBTITLE: 'RPTTIME -- Reports time on system'
  2409. ' $PAGE
  2410. '
  2411. '  SUBROUTINE NAME    --  RPTTIME
  2412. '
  2413. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2414. '
  2415. '  OUTPUT PARAMETERS  --
  2416. '
  2417. '  SUBROUTINE PURPOSE --  Tells user time used on system
  2418. '
  2419.       SUB RPTTIME STATIC
  2420.       CALL SKIPLINE (1)
  2421.       CALL GETIME
  2422.       SUBROUTINE.PARAMETER = 2
  2423.       CALL AMORPM
  2424.       QX = ((HHH * 60) + MMM + (SSS / 60.0)) * 10.0
  2425.       Q! = QX / 10.0
  2426.       MINS = (HHH * 60) + MMM
  2427.       CALL CARRIER
  2428.       IF SUBROUTINE.PARAMETER = -1 THEN _
  2429.          EXIT SUB
  2430.       CALL QTPUT("Now: " + DATE$ + " at " + TIME$,1)
  2431.       CALL QTPUT("On for" + STR$(MINS) + " mins," + STR$(SSS) + " secs",1)
  2432.       END SUB
  2433. ' $SUBTITLE: 'PROTOCOL - Determine protocols available'
  2434. ' $PAGE
  2435. '
  2436. '  SUBROUTINE NAME    -- PROTOCOL
  2437. '
  2438. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  2439. '                        PROTO.DEF$                File of installed protocols
  2440. '
  2441. '   OUTPUT PARAMETERS -- TRANSFER.OPTIONS$         Prompt for protocol choice
  2442. '                        DFLTXFER$                 Letters of protocols
  2443. '                        INTERNAL.EQUIV$           Internal protocol to use
  2444. '
  2445. '  SUBROUTINE PURPOSE -- TO determine what protocols are available to user
  2446. '
  2447.       SUB PROTOCOL STATIC
  2448. 62600 CALL FINDIT (PROTO.DEF$)
  2449.       IF NOT OK THEN _
  2450.          TRANSFER.OPTIONS$ = "A)scii,X)modem,C)rcXmodem,Y)modem" : _
  2451.          INTERNAL.EQUIV$ = "AXCY" : _
  2452.          DFLTXFER$ = "AXCY" : _
  2453.          GOTO 62604
  2454.       DFLTXFER$ = ""
  2455.       INTERNAL.EQUIV$ = ""
  2456.       TRANSFER.OPTIONS$ = ""
  2457.       L = 0
  2458. 62602 IF EOF(2) THEN _
  2459.          GOTO 62604
  2460.       CALL READPARMS (WORK.ARA$(),13,1)
  2461.       IF EC > 0 THEN _
  2462.          EXIT SUB
  2463.       DFLTXFER$ = DFLTXFER$ + " "
  2464.       INTERNAL.EQUIV$ = INTERNAL.EQUIV$ + " "
  2465.       IF USER.SECURITY.LEVEL < VAL(WORK.ARA$(2)) THEN _
  2466.          GOTO 62602
  2467.       IF LEFT$(WORK.ARA$(5),1) = "R" THEN _
  2468.          IF NOT RELIABLE.MODE THEN _
  2469.             GOTO 62602
  2470.       IF LEFT$(WORK.ARA$(3),1) = "I" THEN _
  2471.          GOTO 62603
  2472.       X = INSTR(WORK.ARA$(12)+" "," ")
  2473.       X$ = LEFT$(WORK.ARA$(12),X-1)
  2474.       CALL FINDFILE (X$,FOUND)
  2475.       IF FOUND THEN _
  2476.          X = INSTR(WORK.ARA$(13)+" "," ") : _
  2477.          X$ = LEFT$(WORK.ARA$(13),X-1) : _
  2478.          CALL FINDFILE (X$,FOUND)
  2479.       IF NOT FOUND THEN _
  2480.          GOTO 62602
  2481. 62603 MID$(DFLTXFER$,LEN(DFLTXFER$),1) = LEFT$(WORK.ARA$(1),1)
  2482.       CALL FINDLAST (WORK.ARA$(1),CRLF$,X,I)
  2483.       IF X > 0 AND X >= LEN(WORK.ARA$(1)) - 2 THEN _
  2484.          WORK.ARA$(1) = LEFT$(WORK.ARA$(1),X-1)
  2485.       IF (L + LEN(WORK.ARA$(1)) < 62) AND X = 0 THEN _
  2486.          TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + "," + WORK.ARA$(1) : _
  2487.          L = L + LEN(WORK.ARA$(1)) + 1 _
  2488.       ELSE L = LEN(WORK.ARA$(1)) : _
  2489.            TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + _
  2490.                               CRLF$ + _
  2491.                               WORK.ARA$(1)
  2492.       IF LEFT$(WORK.ARA$(3),1) = "I" AND RIGHT$(WORK.ARA$(3),1) <> "I" THEN _
  2493.          MID$(INTERNAL.EQUIV$,LEN(INTERNAL.EQUIV$),1) = RIGHT$(WORK.ARA$(3),1)
  2494.       GOTO 62602
  2495. 62604 IF INSTR(INTERNAL.EQUIV$,"N") > 0 THEN _
  2496.          GOTO 62605
  2497.       IF X = 0 THEN _
  2498.          TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + ",N)one" _
  2499.       ELSE TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + CRLF$ + "N)one"
  2500.       DFLTXFER$ = DFLTXFER$ + "N"
  2501.       INTERNAL.EQUIV$ = INTERNAL.EQUIV$ + "N"
  2502. 62605 IF LEFT$(TRANSFER.OPTIONS$,1) = "," THEN _
  2503.          TRANSFER.OPTIONS$ = MID$(TRANSFER.OPTIONS$,2)
  2504.       IF INSTR(DFLTXFER$,USER.TRANSFER.DEFAULT$) = 0 THEN _
  2505.          CALL QTPUT ("Protocol "+USER.TRANSFER.DEFAULT$+" unavailable.  Default reset to None",1) : _
  2506.          USER.TRANSFER.DEFAULT$ = MID$(DFLTXFER$,INSTR(INTERNAL.EQUIV$,"N"),1)
  2507.       END SUB
  2508. ' $SUBTITLE: 'TRANSFER - subroutine for KERMIT, YMODEM, IMODEM & YMODEM'
  2509. ' $PAGE
  2510. '
  2511. '  SUBROUTINE NAME    -- TRANSFER
  2512. '
  2513. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  2514. '                        TRANSFER.FUNCTION         = 1 DOWNLOAD FILE TO USER
  2515. '                                                  = 2 UPLOAD FILE TO RBBS-PC
  2516. '                        FILE.NAME$                NAME OF FILE FOR TRANSFER
  2517. '                        COM.PORT$                 NAME OF COMMUNICATIONS PORT
  2518. '                                                  TO BE USED BY KERMIT (COM1
  2519. '                                                  OR COM2)
  2520. '                        BPS                       = -1 FOR   300 BAUD
  2521. '                                                  = -2 FOR   450 BAUD
  2522. '                                                  = -3 FOR  1200 BAUD
  2523. '                                                  = -4 FOR  2400 BAUD
  2524. '                                                  = -5 FOR  4800 BAUD
  2525. '                                                  = -6 FOR  9600 BAUD
  2526. '                                                  = -7 FOR 19200 BAUD
  2527. '                        PCKERMIT.EXE.FILE$        FILE TO TRANSFER CONTROL TO
  2528. '                                                  FOR KERMIT PROTOCOL ON
  2529. '                                                  PROTOCOL.PATH$.
  2530. '                        QMXFER.COM.FILE$          FILE TO TRANSFER CONTROL TO
  2531. '                                                  FOR YMODEM, IMODEM OR
  2532. '                                                  YMODEMG PROTOCOLS.
  2533. '                        WXMODEM.COM.FILE$         FILE TO TRANSFER CONTROL TO
  2534. '                                                  FOR WXMODEM PROTOCOL ON
  2535. '                                                  PROTOCOL.PATH$
  2536. '
  2537. '  OUTPUT PARAMETERS  -- NONE
  2538. '
  2539. '  SUBROUTINE PURPOSE -- TO TRANSFER FILES USING KERMIT, YMODEM, IMODEM,
  2540. '                        YMODEMG OR WXMODEM PROTOCOL'S
  2541. '
  2542. 62620 SUB TRANSFER STATIC
  2543.       IF PRIVATE.DOOR THEN _
  2544.          CALL XFRETURN : _
  2545.          EXIT SUB
  2546.       IF TRANSFER.FUNCTION = 1 THEN _
  2547.          B$ = DOWN.TEMPLATE$ : _
  2548.          Z$ = "send " _
  2549.       ELSE IF TRANSFER.FUNCTION = 2 THEN _
  2550.               B$ = UP.TEMPLATE$ : _
  2551.               Z$ = "receive "
  2552.       CALL METAGSR (B$)
  2553.       CALL QTPUT ("Protocol: "+PROTO.PROMPT$,1)
  2554.       CALL QTPUT ("Ready to " + Z$ + " ",0)
  2555.       IF BATCH.TRANSFER THEN _
  2556.          CALL QTPUT ("(BATCH)",1) : _
  2557.          CALL OPENWORK (NODE.WORK.FILE$) : _
  2558.          WHILE NOT EOF(2) : _
  2559.            CALL READANY : _
  2560.            CALL BRKFNAME (A$,Z$,Y$,X$,TRUE) : _
  2561.            CALL QTPUT ("   "+Y$+X$,1) : _
  2562.          WEND _
  2563.       ELSE CALL QTPUT (FILE.NAME.HOLD$,1)
  2564.       CALL XFRETURN
  2565.       END SUB
  2566. ' $SUBTITLE: 'XFRETURN - subroutine to exit as a private door.'
  2567. ' $PAGE
  2568. '
  2569. '  SUBROUTINE NAME    -- XFRETURN
  2570. '
  2571. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  2572. '                        TRANSFER.FUNCTION         = 1 DOWNLOAD FILE TO USER
  2573. '                                                  = 2 UPLOAD FILE TO RBBS-PC
  2574. '                                                  = 3 USER REGISTRATION PGM
  2575. '                        B$                        NAME OF FILE TO EXIT TO
  2576. '                        COM.PORT$                 NAME OF COMMUNICATIONS PORT
  2577. '                                                  TO BE USED BY KERMIT (COM1
  2578. '                                                  OR COM2)
  2579. '                        BPS                       = -1 FOR   300 BAUD
  2580. '                                                  = -2 FOR   450 BAUD
  2581. '                                                  = -3 FOR  1200 BAUD
  2582. '                                                  = -4 FOR  2400 BAUD
  2583. '                                                  = -5 FOR  4800 BAUD
  2584. '                                                  = -6 FOR  9600 BAUD
  2585. '                                                  = -7 FOR 19200 BAUD
  2586. '                        QMXFER.COM.FILE$          FILE TO TRANSFER CONTROL TO
  2587. '                                                  FOR YMODEM, IMODEM OR
  2588. '                                                  YMODEMG PROTOCOLS.
  2589. '
  2590. '  OUTPUT PARAMETERS  -- NONE
  2591. '
  2592. '  SUBROUTINE PURPOSE -- TO TRANSFER CONTROL TO ANOTHER PROGRAM
  2593. '
  2594.       SUB XFRETURN STATIC
  2595.       IF PRIVATE.DOOR THEN _
  2596.          GOTO 62630
  2597.       IF FAKE.XRPT THEN _
  2598.          CALL FAKEXRPT (FT$)
  2599.       IF ADVANCE.PROTO.WRITE THEN _
  2600.          CALL OPENOUTW ("XFER-"+NODE.ID$+".DEF") : _
  2601.          IF EC < 1 THEN _
  2602.             CALL PRNTWRKA (FILE.NAME$+",,"+FT$) : _
  2603.             CLOSE 2
  2604.       IF PROTO.METHOD$ = "S" THEN _
  2605.          GOTO 62629
  2606. 62628 X$ = LEFT$(B$,INSTR(B$+" "," ")-1)
  2607.       IF X$ = "" THEN _
  2608.          EXIT SUB
  2609.       CALL FINDIT (X$)
  2610.       IF NOT OK THEN _
  2611.          A$ = "Missing door program" : _
  2612.          CALL UPDTCALR (A$ + " " + X$,1) : _
  2613.          SNOOP = TRUE : _
  2614.          CALL LPRNT (A$,1) : _
  2615.          EXIT SUB
  2616.       A$(1) = DISK.FOR.DOS$ + _
  2617.               "COMMAND /C " + _
  2618.               B$
  2619.       A$(2) = RBBS.BAT$
  2620.       PRIVATE.DOOR = TRUE
  2621.       CALL QTPUT ("Exiting to External Program for File Tranfer",1)
  2622.       'IF TRANSFER.FUNCTION < 3 THEN _
  2623.       '   X$ = "File Tranfer.  Please begin..." _
  2624.       'ELSE X$ = "Registration"
  2625.       'CALL QTPUT (X$,1)
  2626.       LOCATE 25,1
  2627.       CALL LPRNT(LINE.FEED$,0)
  2628.       CALL RBBSEXIT (A$(),2)
  2629. 62629 CALL DELAYIT (8 + BPS)
  2630.       IF FOSSIL THEN _
  2631.          CALL FOSEXIT(COMPORT%) _
  2632.       ELSE CLOSE 3 : _
  2633.            OUT MODEM.CONTROL.REGISTER,INP(MODEM.CONTROL.REGISTER) OR 1
  2634.       SHELL B$
  2635.       IF FOSSIL THEN _
  2636.          CALL FOSINIT(COMPORT%,RESULT%) : _
  2637.          IF RESULT% = -1 THEN _
  2638.             CALL PSCRN("ERROR INITIALIZING FOSSIL AFTER EXTERNAL PROTOCOL") : _
  2639.             SYSTEM
  2640.       CALL DELAYIT (2)
  2641. 62630 PARITY$ = MID$(",N,8,1,E,7,1",7 + 6 * EIGHT.BIT,6)
  2642.       IF LOCAL.USER THEN _
  2643.          GOTO 62631
  2644.       IF FOSSIL THEN _
  2645.          CALL SETBAUD _
  2646.       ELSE CALL OPENCOM(TALK.TO.MODEM.AT$,PARITY$)
  2647.       IF PRIVATE.DOOR THEN _
  2648.          CALL DELAYIT (7 + BPS) : _
  2649.          CALL QTPUT ("Reloading RBBS-PC.  Please be patient.",1)
  2650. 62631 CALL SKIPLINE (2)
  2651.       LOCATE 24,1
  2652. 62632 END SUB
  2653. ' $SUBTITLE: 'FAKEXRPT - subroutine to create fake xfer report'
  2654. ' $PAGE
  2655. '
  2656. '  SUBROUTINE NAME    --  FAKEXRPT
  2657. '
  2658. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2659. '                         FILE.NAME.HOLD$      FILE TO BE TRANSFERRED
  2660. '                         PROTO.USED$          PROTOCOL USED
  2661. '
  2662. '  OUTPUT PARAMETERS  --  WRITES OUT TRANSFER FILE REPORT
  2663. '
  2664. '  SUBROUTINE PURPOSE --  EXTERNAL PROTOCOL DRIVERS THAT DO NOT WRITE
  2665. '                         OUT A STANDARD TRANSFER REPORT MUST HAVE ONE
  2666. '                         PROVIDED IN ORDER FOR "DOORING" TO EXTERNAL
  2667. '                         PROTOCOLS TO WORK PROPERLY, SINCE THIS FILE
  2668. '                         IS READ UPON RETURNING FROM AN EXTERNAL PROTOCOL.
  2669. '
  2670. 62650 SUB FAKEXRPT (PROTO.USED$) STATIC
  2671.       CLOSE 2
  2672.       OPEN "O",2,"XFER-" + _
  2673.                  NODE.FILE.ID$ + _
  2674.                  ".DEF"
  2675.       PRINT #2,FILE.NAME$
  2676.       PRINT #2,
  2677.       PRINT #2,PROTO.USED$
  2678.       PRINT #2,"S"
  2679.       CLOSE 2
  2680.       END SUB
  2681. ' $SUBTITLE: 'SETEXPERT - subroutine to adjust for expert change'
  2682. ' $PAGE
  2683. '
  2684. '  SUBROUTINE NAME    --  SETEXPERT
  2685. '
  2686. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2687. '                         EXPERT.USER          WHETHER IS AN EXPERT
  2688. '
  2689. '  OUTPUT PARAMETERS  --  MORE.PROMPT$         Pause prompt
  2690. '                         PRESS.ENTER$         Prompt to press enter
  2691. '
  2692. '  SUBROUTINE PURPOSE --  EXTERNAL PROTOCOL DRIVERS THAT DO NOT WRITE
  2693. '                         OUT A STANDARD TRANSFER REPORT MUST HAVE ONE
  2694. '                         PROVIDED IN ORDER FOR "DOORING" TO EXTERNAL
  2695. '                         PROTOCOLS TO WORK PROPERLY, SINCE THIS FILE
  2696. '                         IS READ UPON RETURNING FROM AN EXTERNAL PROTOCOL.
  2697. '
  2698. 62660 SUB SETEXPERT STATIC
  2699.       IF EXPERT.USER THEN _
  2700.          MORE.PROMPT$ = "More <[Y],N,C,A" : _
  2701.          PRESS.ENTER$ = PRESS.ENTER.EXPERT$ : _
  2702.          EXIT SUB
  2703.       MORE.PROMPT$ = "More [Y]es,N)o,C)ontinuous,A)bort"
  2704.       PRESS.ENTER$ = PRESS.ENTER.NOVICE$
  2705.       END SUB
  2706. ' $SUBTITLE: 'TIMEDOUT - subroutine to exit based on time of day'
  2707. ' $PAGE
  2708. '
  2709. '  SUBROUTINE NAME    --  TIMEDOUT
  2710. '
  2711. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2712. '                         RCTTY.BAT$
  2713. '                         NODE.RECORD.INDEX
  2714. '                         MESSAGE.RECORD$
  2715. '                         MODEM.INIT.BAUD$
  2716. '                         MODEM.GO.OFFHOOK.COMMADN$
  2717. '
  2718. '  OUTPUT PARAMETERS  --  NONE
  2719. '
  2720. '  SUBROUTINE PURPOSE --  WHEN RBBS-PC IS TO EXIT TO DOS AT A SPECIFIC TIME OF
  2721. '                         DAY, THIS ROUTINE WRITES OUT TO THE FILE SPECIFIED
  2722. '                         IN "RCTTY.BAT$" THE ONE-LINE ENTRY:
  2723. '                                    RBBSTIMx.BAT
  2724. '                         WHERE "x" IS EQUAL TO THE NODE ID.
  2725. '
  2726. 63000 SUB TIMEDOUT STATIC
  2727.       FIELD #1,128 AS MESSAGE.RECORD$
  2728.       SUBROUTINE.PARAMETER = 3
  2729.       CALL FILELOCK
  2730.       GET 1,NODE.RECORD.INDEX
  2731.       X$ = DATE$
  2732.       CALL CSTRDATE (X$,Y$)
  2733.       MID$(MESSAGE.RECORD$,77,2) = Y$
  2734.       MID$(MESSAGE.RECORD$,86,5) = LEFT$(TIME$,5)
  2735.       PUT 1,NODE.RECORD.INDEX
  2736.       SUBROUTINE.PARAMETER = 2
  2737.       CALL FILELOCK
  2738.       CLOSE 2
  2739.       CALL BRKFNAME(CALLERS.FILE$,X$,Y$,Z$,TRUE)
  2740.       FILE.NAME$ = X$ + "RBBS" + NODE.FILE.ID$ + "TM.DEF"
  2741.       OPEN "O",2,FILE.NAME$
  2742.       PRINT #2,MID$(FILE.NAME$,3,7)
  2743.       CLOSE 2
  2744.       IF LOCAL.USER.MODE THEN _
  2745.          EXIT SUB
  2746.       IF SUBROUTINE.PARAMETER <> 7 THEN _
  2747.          SUBROUTINE.PARAMETER = 4 : _
  2748.          CALL FILELOCK : _
  2749.          CALL OPENCOM(MODEM.INIT.BAUD$,",N,8,1")
  2750.       CALL MODEMPUT (MODEM.GO.OFFHOOK.COMMAND$)
  2751.       IF MULTI.LINK.PRESENT <> 0 THEN _
  2752.          CALL DELAYIT (3)
  2753.       END SUB
  2754. ' $SUBTITLE: 'ASKUSERS - subroutine to get registration information'
  2755. ' $PAGE
  2756. '
  2757. '  SUBROUTINE NAME    --  ASKUSERS  (WRITTEN BY JON MARTIN)
  2758. '
  2759. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2760. '                         FILE.NAME$           NAME OF THE FILE CONTAINING THE
  2761. '                                              SCRIPT TO BE USED WHEN ASKING
  2762. '                                              THE USER QUESTIONS.
  2763. '                         ACTIVE.USER.NAME$    NAME OF THE CURRENT USER
  2764. '                         USER.SECURITY.LEVEL  USER'S SECURITY
  2765. '                         UPPER.CASE           SET IF USER NEEDS UPPERCASE
  2766. '
  2767. '  OUTPUT PARAMETERS  --  WRITE THE USER'S RESPONSES TO THE QUESTIONS TO THE
  2768. '                         FILE NAME SPECIFIED AS THE FIRST PARAMETER IN THE
  2769. '                         FIRST RECORD OF THE FILE CONTAINING THE SCRIPT TO
  2770. '                         BE USED.
  2771. '                         USER.SECURITY.LEVEL  CAN BE RAISED OR LOWERED
  2772. '
  2773. '  SUBROUTINE PURPOSE --  PROVIDES A SOPHISTCATED, SCRIPT DRIVEN MECHANISM BY
  2774. '                         WHICH A SYSOP CAN SOLICIT INFORMATION FROM NEW USERS
  2775. '                         (VIA A SCRIPT THAT REQUESTS REGISTRATION INFORMATION
  2776. '                         AND WHICH CAN UPPER OR LOWER HIS DEFAULT SECURITY
  2777. '                         LEVEL BASED ON THE RESPONSES) OR ASK A QUESTIONS OF
  2778. '                         WHEN THE USER LOGS OFF.  THE FORMER OCCURS IF THE
  2779. '                         FILE "RBBS-REG.DEF" CONTAINING THE REGISTRATION
  2780. '                         SCRIPT EXISTS ON THE SAME DRIVE AS THE "WELCOME".
  2781. '                         THE LATER EXISTS IF THE FILE "EPILOG.DEF" EXISTS ON
  2782. '                         THE SAME DRIVE AS THE "WELCOME".
  2783. '
  2784.       SUB ASKUSERS STATIC
  2785. '
  2786. ' *
  2787. ' *  LOAD SCRIPT CONTAING THE QUESTIONS INTO THE A$ DIMENSION                 *
  2788. ' *
  2789. '
  2790. 64005 CHAT.AVAILABLE = FALSE
  2791.       QUESTIONNAIRE.CHAIN = FALSE
  2792.       CALL OPENWORK (FILE.NAME$)
  2793.       INPUT #2,APPEND.FILE.NAME$,MAXIMUM.SECURITY.LEVEL
  2794. '
  2795. ' *
  2796. ' *  THE FIRST RECORD OF THE SCRIPT FILE CONTAINS TWO PARAMETERS:             *
  2797. ' *   1.  THE NAME OF THE FILE TO APPEND THE ANSWERS TO.                      *
  2798. ' *   2.  THE MAXIMUM SECURITY LEVEL THE + COMMAND CAN RAISE A USER SECURITY  *
  2799. ' *
  2800.       SCRIPT.INDEX = 1
  2801.       A$(SCRIPT.INDEX) = ACTIVE.USER.NAME$ + _
  2802.                          " " + _
  2803.                          DATE$ + _
  2804.                          " " + _
  2805.                          TIME$
  2806. 64010 IF EOF(2) OR SCRIPT.INDEX > 255 THEN _
  2807.          GOTO 64100
  2808.       SCRIPT.INDEX = SCRIPT.INDEX + 1
  2809.       LINE INPUT #2,A$(SCRIPT.INDEX)
  2810.       IF UPPER.CASE THEN _
  2811.          CALL ALLCAPS (A$(SCRIPT.INDEX))
  2812.       IF LEFT$(A$(SCRIPT.INDEX),1) = "?" THEN _
  2813.          SCRIPT.INDEX = SCRIPT.INDEX + 1 : _
  2814.          A$(SCRIPT.INDEX) = "!"
  2815.       GOTO 64010
  2816. '
  2817. ' *
  2818. ' *  PROCESS QUESTIONS IN THE SCRIPT AS FOLLOWS:                              *
  2819. ' *                                                                           *
  2820. ' * FIRST COLUMN     MEANING                                                  *
  2821. ' *      :        THIS LINE IS A LABEL THAT MAY BE BRANCHED TO                *
  2822. ' *      !        THIS MEANS THIS IS AN ANSWER                                *
  2823. ' *      >        THIS IS A "GOTO" COMMAND TO ONE OF THE LABELS               *
  2824. ' *      *        THIS MEANS THE LINE IS A MESSAGE TO BE WRITTEN TO THE USER  *
  2825. ' *      ?        THIS MEANS THIS IS A QUESTION FOR THE USER                  *
  2826. ' *      =        THIS MEANS THAT THIS LINE CONTAINS DECISION CRITERIA        *
  2827. ' *      -        THIS MEANS TO LOWER THE USER'S SECURITY LEVEL               *
  2828. ' *      +        THIS MEANS TO RAISE THE USER'S SECURITY LEVEL               *
  2829. ' *      @        THIS MEANS TO ABORT THE QUESTIONNAIRE DO NOT WRITE OUT      *
  2830. ' *      &        THIS MEANS TO CHAIN TO ANOTHER QUESTIONNAIRE                *
  2831. ' *
  2832. '
  2833. 64100 SCRIPT.MAX = SCRIPT.INDEX
  2834.       SCRIPT.INDEX = 1
  2835. 64110 CALL CARRIER
  2836.       IF SUBROUTINE.PARAMETER = -1 THEN _
  2837.          GOTO 64115
  2838.       SCRIPT.INDEX = SCRIPT.INDEX + 1
  2839.       IF SCRIPT.INDEX > SCRIPT.MAX THEN _
  2840.          GOTO 64400
  2841.       IF LEFT$(A$(SCRIPT.INDEX),1) = ":" THEN _         ' LABEL
  2842.          GOTO 64110
  2843.       IF LEFT$(A$(SCRIPT.INDEX),1) = "!" THEN _         ' ANSWER
  2844.          GOTO 64110
  2845.       IF LEFT$(A$(SCRIPT.INDEX),1) = "@" THEN _         ' ABORT
  2846.          QUESTIONNAIRE.ABORTED = TRUE : _
  2847.          GOTO 64510
  2848.       IF LEFT$(A$(SCRIPT.INDEX),1) = ">" THEN _         ' GOTO
  2849.          BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),2) : _
  2850.          GOSUB 64200 : _
  2851.          IF SUBROUTINE.PARAMETER = -1 THEN _
  2852.             GOTO 64510 _
  2853.          ELSE GOTO 64110
  2854.       IF LEFT$(A$(SCRIPT.INDEX),1) = "*" THEN _         ' MESSAGE
  2855.          A$ = MID$(A$(SCRIPT.INDEX),2) : _
  2856.          SUBROUTINE.PARAMETER = 5 : _
  2857.          CALL TPUT : _
  2858.          IF SUBROUTINE.PARAMETER = -1 THEN _
  2859.             GOTO 64510 _
  2860.          ELSE GOTO 64110
  2861. 64113 IF LEFT$(A$(SCRIPT.INDEX),1) = "?" THEN _         ' QUESTION
  2862.          A$ = MID$(A$(SCRIPT.INDEX),2) : _
  2863.          SUBROUTINE.PARAMETER = 1 : _
  2864.          CALL TGET : _
  2865.          IF SUBROUTINE.PARAMETER = -1 THEN _
  2866.             GOTO 64510 _
  2867.          ELSE IF Q = 0 THEN _
  2868.                  GOTO 64113 _
  2869.               ELSE A$(SCRIPT.INDEX + 1) = "!" + _
  2870.                                           B$ : _
  2871.                    GOTO 64110
  2872.       IF LEFT$(A$(SCRIPT.INDEX),2) = "=#" THEN _                     ' NUMERIC
  2873.          GOSUB 64350 : _
  2874.          GOTO 64110
  2875.       IF LEFT$(A$(SCRIPT.INDEX),1) = "=" THEN _         ' DECISION
  2876.          GOSUB 64300 : _
  2877.          IF SUBROUTINE.PARAMETER = -1 THEN _
  2878.             GOTO 64510 _
  2879.          ELSE GOTO 64110
  2880.       IF LEFT$(A$(SCRIPT.INDEX),1) = "-" THEN _         ' LOWER
  2881.          ADJUSTED.SECURITY = -1 : _
  2882.          USER.SECURITY.LEVEL = USER.SECURITY.LEVEL - _
  2883.                                VAL(MID$(A$(SCRIPT.INDEX),2,5)) : _
  2884.          USER.SECURITY.SAVE = USER.SECURITY.LEVEL : _
  2885.          GOTO 64110
  2886.       IF LEFT$(A$(SCRIPT.INDEX),1) = "+" THEN _         ' RAISE
  2887.          IF USER.SECURITY.LEVEL + VAL(MID$(A$(SCRIPT.INDEX),2,5)) _
  2888.             <= MAXIMUM.SECURITY.LEVEL THEN _
  2889.                ADJUSTED.SECURITY = -1 : _
  2890.                USER.SECURITY.SAVE = USER.SECURITY.LEVEL : _
  2891.                USER.SECURITY.LEVEL = USER.SECURITY.LEVEL + _
  2892.                                VAL(MID$(A$(SCRIPT.INDEX),2,5))
  2893.       IF LEFT$(A$(SCRIPT.INDEX),1) = "+" THEN _
  2894.          GOTO 64110
  2895.       IF LEFT$(A$(SCRIPT.INDEX),1) = "&" THEN _
  2896.          QUESTIONNAIRE.CHAIN = TRUE : _
  2897.          FILE.NAME.HOLD$ = MID$(A$(SCRIPT.INDEX),2) : _
  2898.          GOTO 64110
  2899.       A$ = "Invalid line.  Column 1 is <" + LEFT$(A$(SCRIPT.INDEX),1)+">.  Must be: * ? = + - > @ &"
  2900.       SUBROUTINE.PARAMETER = 5
  2901.       CALL TPUT
  2902. 64115 GOTO 64510
  2903. '
  2904. ' *
  2905. ' *  SEARCH FOR GOTO LABEL                                                    *
  2906. ' *
  2907. '
  2908. 64200 SCRIPT.INDEX = 1
  2909. 64210 SCRIPT.INDEX = SCRIPT.INDEX + 1
  2910.       IF SCRIPT.INDEX > SCRIPT.MAX THEN _
  2911.          A$ = BRANCH.LABEL$ + _
  2912.               " not found!" : _
  2913.          SUBROUTINE.PARAMETER = 5 : _
  2914.          CALL TPUT : _
  2915.          IF SUBROUTINE.PARAMETER = -1 THEN _
  2916.             RETURN _
  2917.          ELSE GOTO 64115
  2918.       IF LEFT$(A$(SCRIPT.INDEX),1) <> ":" THEN _
  2919.          GOTO 64210
  2920.       IF MID$(A$(SCRIPT.INDEX),2) <> BRANCH.LABEL$ THEN _
  2921.          GOTO 64210
  2922.       RETURN
  2923. '
  2924. ' *
  2925. ' *  DETERMINE BRANCH LOGIC                                                   *
  2926. ' *
  2927. '
  2928. 64300 CURRENT.EQUALS = 1
  2929.       Z$ = RIGHT$(A$(SCRIPT.INDEX - 1),1)
  2930.       CALL ALLCAPS (Z$)
  2931. 64310 NEXT.EQUALS = INSTR(CURRENT.EQUALS + 1, A$(SCRIPT.INDEX),"=")
  2932.       IF NEXT.EQUALS = 0 THEN _
  2933.          BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2) : _
  2934.          GOTO 64320
  2935.       IF Z$ <> _
  2936.          MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 1,1) THEN  _
  2937.          CURRENT.EQUALS = NEXT.EQUALS : _
  2938.          GOTO 64310
  2939.       BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2,NEXT.EQUALS-(CURRENT.EQUALS + 2))
  2940. 64320 GOSUB 64200
  2941.       RETURN
  2942. '
  2943. ' *
  2944. ' *  DETERMINE NUMERIC BRANCH LOGIC                                           *
  2945. ' *
  2946. '
  2947. 64350 CURRENT.EQUALS = 1
  2948. 64360 NEXT.EQUALS = INSTR(CURRENT.EQUALS + 1, A$(SCRIPT.INDEX),"=")
  2949.       IF NEXT.EQUALS = 0 THEN _
  2950.          BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2) : _
  2951.          GOTO 64380
  2952.       NUMERIC = TRUE
  2953.       LOOP.INDEX = 2
  2954.       WHILE LOOP.INDEX < LEN(A$(SCRIPT.INDEX - 1)) +1
  2955.          IF INSTR("()1234567890- ",MID$(A$(SCRIPT.INDEX - 1),LOOP.INDEX,1)) THEN _
  2956.             GOTO 64370
  2957.          NUMERIC = FALSE
  2958. 64370    LOOP.INDEX = LOOP.INDEX + 1
  2959.       WEND
  2960.       IF NOT NUMERIC THEN _
  2961.          CURRENT.EQUALS = NEXT.EQUALS : _
  2962.          GOTO 64360
  2963.       BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2,NEXT.EQUALS-(CURRENT.EQUALS + 2))
  2964. 64380 GOSUB 64200
  2965.       RETURN
  2966. '
  2967. ' *
  2968. ' *  WRITE RESPONSES TO DESIGNATED FILE                                       *
  2969. ' *
  2970. '
  2971. 64400 SCRIPT.INDEX = 0
  2972.       EC = 0
  2973.       SUBROUTINE.PARAMETER = 9
  2974.       FILE.NAME$ = APPEND.FILE.NAME$
  2975.       EN$ = APPEND.FILE.NAME$
  2976.       CALL FILELOCK
  2977.       CALL OPENWRKA (APPEND.FILE.NAME$)
  2978.       IF EC <> 0 THEN _
  2979.          A$ = "Fatal Error in script!" : _
  2980.          SUBROUTINE.PARAMETER = 5 : _
  2981.          CALL TPUT : _
  2982.          GOTO 64500
  2983. 64410 SCRIPT.INDEX = SCRIPT.INDEX + 1
  2984.       IF SCRIPT.INDEX > SCRIPT.MAX THEN _
  2985.          GOTO 64500
  2986.       IF LEFT$(A$(SCRIPT.INDEX),1) = ":" THEN _
  2987.          QUESTION.SAVE$ = MID$(A$(SCRIPT.INDEX),2) : _
  2988.          GOTO 64410
  2989.       IF LEFT$(A$(SCRIPT.INDEX),1) = "!" AND _
  2990.          LEN(A$(SCRIPT.INDEX)) < 2 THEN _
  2991.          GOTO 64410
  2992.       IF LEFT$(A$(SCRIPT.INDEX),1) = "!" THEN _
  2993.          CALL PRNTWRKA (QUESTION.SAVE$) : _
  2994.          CALL PRNTWRKA (MID$(A$(SCRIPT.INDEX),2))
  2995.       IF SCRIPT.INDEX = 1 AND _
  2996.          NOT QUESTIONNAIRE.CHAIN.STARTED THEN _
  2997.          CALL PRNTWRKA (A$(SCRIPT.INDEX))
  2998.       IF EC <> 0 THEN _
  2999.          A$ = "Unrecoverable failure in script!" : _
  3000.          SUBROUTINE.PARAMETER = 5 : _
  3001.          CALL TPUT : _
  3002.          GOTO 64500
  3003.       GOTO 64410
  3004. 64500 CLOSE 2
  3005.       SUBROUTINE.PARAMETER = 10
  3006.       CALL FILELOCK
  3007.       CALL CARRIER
  3008.       IF QUESTIONNAIRE.CHAIN THEN _
  3009.          QUESTIONNAIRE.CHAIN.STARTED = TRUE : _
  3010.          FILE.NAME$ = FILE.NAME.HOLD$ : _
  3011.          GOTO 64005
  3012. 64510 CHAT.AVAILABLE = (INSTR("MUF",ACTIVE.MENU$) > 0)
  3013.       END SUB
  3014. ' $SUBTITLE: 'VIEWARC - subroutine to display .ARC contents'
  3015. ' $PAGE
  3016. '
  3017. '  SUBROUTINE NAME    --  VIEWARC  (Written by Jon Martin)
  3018. '
  3019. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  3020. '                         FILE.NAME$           NAME OF THE ARC FILE TO BE
  3021. '                                              VIEWED.
  3022. '
  3023. '  OUTPUT PARAMETERS  --  NONE
  3024. '
  3025. '  SUBROUTINE PURPOSE --  PROVIDES A MECHANISM TO PROVIDE USERS WITH THE
  3026. '                         CONTENTS OF AN ARC FILE PRIOR TO DOWNLOADING.
  3027.       SUB VIEWARC STATIC
  3028. 64600 IF TURBO.RBBS THEN _
  3029.          RETCODE% = 0 : _
  3030.          CALL ARCV (ARC.WORK$,FILE.NAME$,RETCODE%) : _
  3031.          CALL BUFFILE (ARC.WORK$,X) : _
  3032.          EXIT SUB
  3033.       CLOSE 2
  3034.       OPEN "R",2,FILE.NAME$,1
  3035.       FIELD 2,1 AS CHAR$
  3036.       BYTE.POINTER! = 1
  3037.       ARC.END! = LOF(2)
  3038. 64605 IF BYTE.POINTER! > ARC.END! THEN _
  3039.          GOTO 64620
  3040.       GET 2,BYTE.POINTER!
  3041.       IF CHAR$ <> CHR$(26) THEN _
  3042.          GOTO 64620
  3043.       BYTE.POINTER! = BYTE.POINTER! + 1
  3044.       GET 2,BYTE.POINTER!
  3045.       IF CHAR$ = CHR$(0) THEN _
  3046.          GOTO 64620
  3047.       ARCED.NAME$ = ""
  3048.       FOR X = 1 TO 12
  3049.          GET 2,BYTE.POINTER! + X
  3050.          IF CHAR$ < CHR$(40) THEN _
  3051.             GOTO 64610
  3052.          ARCED.NAME$ = ARCED.NAME$ + _
  3053.                        CHAR$
  3054.       NEXT
  3055. 64610 A$ = ARCED.NAME$
  3056.       BYTE.POINTER! = BYTE.POINTER! + 14
  3057.       GOSUB 64630
  3058.       TOTAL.BYTES# = WORK.BYTES#
  3059.       BYTE.POINTER! = BYTE.POINTER! + 10
  3060.       GOSUB 64630
  3061.       FINAL.BYTES# = WORK.BYTES#
  3062.       A$ = A$ + _
  3063.            SPACE$(20 - LEN(ARCED.NAME$) - LEN(STR$(FINAL.BYTES#))) + _
  3064.            STR$(FINAL.BYTES#) + _
  3065.            " bytes."
  3066.       CALL QTPUT(A$,1)
  3067.       BYTE.POINTER! = BYTE.POINTER! + TOTAL.BYTES# + 4
  3068.       GOTO 64605
  3069. 64620 CLOSE 2
  3070.       SUBROUTINE.PARAMETER = 0
  3071.       CALL CARRIER
  3072.       A$ = ""
  3073.       EXIT SUB
  3074. 64630 FACTOR# = 1#
  3075.       WORK.BYTES# = 0
  3076.       FOR X = 0 TO 3
  3077.          GET 2,BYTE.POINTER! + X
  3078.          WORK.BYTES# = WORK.BYTES# + FACTOR# * ASC(CHAR$)
  3079.          FACTOR# = FACTOR# * 256#
  3080.       NEXT
  3081.       RETURN
  3082.       END SUB
  3083.